1 /* Copyright (C) 2002-2023 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or 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)
10 any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 /* Unix stream I/O module */
27
28 #include "io.h"
29 #include "unix.h"
30 #include "async.h"
31 #include <limits.h>
32
33 #ifdef HAVE_UNISTD_H
34 #include <unistd.h>
35 #endif
36
37 #include <sys/stat.h>
38 #include <fcntl.h>
39
40 #include <string.h>
41 #include <errno.h>
42
43
44 /* For mingw, we don't identify files by their inode number, but by a
45 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
46 #ifdef __MINGW32__
47
48 #define WIN32_LEAN_AND_MEAN
49 #include <windows.h>
50
51 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
52 #undef lseek
53 #define lseek _lseeki64
54 #undef fstat
55 #define fstat _fstati64
56 #undef stat
57 #define stat _stati64
58 #endif
59
60 #ifndef HAVE_WORKING_STAT
61 static uint64_t
62 id_from_handle (HANDLE hFile)
63 {
64 BY_HANDLE_FILE_INFORMATION FileInformation;
65
66 if (hFile == INVALID_HANDLE_VALUE)
67 return 0;
68
69 memset (&FileInformation, 0, sizeof(FileInformation));
70 if (!GetFileInformationByHandle (hFile, &FileInformation))
71 return 0;
72
73 return ((uint64_t) FileInformation.nFileIndexLow)
74 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
75 }
76
77
78 static uint64_t
79 id_from_path (const char *path)
80 {
81 HANDLE hFile;
82 uint64_t res;
83
84 if (!path || !*path || access (path, F_OK))
85 return (uint64_t) -1;
86
87 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
88 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
89 NULL);
90 res = id_from_handle (hFile);
91 CloseHandle (hFile);
92 return res;
93 }
94
95
96 static uint64_t
97 id_from_fd (const int fd)
98 {
99 return id_from_handle ((HANDLE) _get_osfhandle (fd));
100 }
101
102 #endif /* HAVE_WORKING_STAT */
103
104
105 /* On mingw, we don't use umask in tempfile_open(), because it
106 doesn't support the user/group/other-based permissions. */
107 #undef HAVE_UMASK
108
109 #endif /* __MINGW32__ */
110
111
112 /* These flags aren't defined on all targets (mingw32), so provide them
113 here. */
114 #ifndef S_IRGRP
115 #define S_IRGRP 0
116 #endif
117
118 #ifndef S_IWGRP
119 #define S_IWGRP 0
120 #endif
121
122 #ifndef S_IROTH
123 #define S_IROTH 0
124 #endif
125
126 #ifndef S_IWOTH
127 #define S_IWOTH 0
128 #endif
129
130
131 #ifndef HAVE_ACCESS
132
133 #ifndef W_OK
134 #define W_OK 2
135 #endif
136
137 #ifndef R_OK
138 #define R_OK 4
139 #endif
140
141 #ifndef F_OK
142 #define F_OK 0
143 #endif
144
145 /* Fallback implementation of access() on systems that don't have it.
146 Only modes R_OK, W_OK and F_OK are used in this file. */
147
148 static int
149 fallback_access (const char *path, int mode)
150 {
151 int fd;
152
153 if (mode & R_OK)
154 {
155 if ((fd = open (path, O_RDONLY)) < 0)
156 return -1;
157 else
158 close (fd);
159 }
160
161 if (mode & W_OK)
162 {
163 if ((fd = open (path, O_WRONLY)) < 0)
164 return -1;
165 else
166 close (fd);
167 }
168
169 if (mode == F_OK)
170 {
171 struct stat st;
172 return stat (path, &st);
173 }
174
175 return 0;
176 }
177
178 #undef access
179 #define access fallback_access
180 #endif
181
182
183 /* Fallback directory for creating temporary files. P_tmpdir is
184 defined on many POSIX platforms. */
185 #ifndef P_tmpdir
186 #ifdef _P_tmpdir
187 #define P_tmpdir _P_tmpdir /* MinGW */
188 #else
189 #define P_tmpdir "/tmp"
190 #endif
191 #endif
192
193
194 /* Unix and internal stream I/O module */
195
196 static const int FORMATTED_BUFFER_SIZE_DEFAULT = 8192;
197 static const int UNFORMATTED_BUFFER_SIZE_DEFAULT = 128*1024;
198
199 typedef struct
200 {
201 stream st;
202
203 gfc_offset buffer_offset; /* File offset of the start of the buffer */
204 gfc_offset physical_offset; /* Current physical file offset */
205 gfc_offset logical_offset; /* Current logical file offset */
206 gfc_offset file_length; /* Length of the file. */
207
208 char *buffer; /* Pointer to the buffer. */
209 ssize_t buffer_size; /* Length of the buffer. */
210 int fd; /* The POSIX file descriptor. */
211
212 int active; /* Length of valid bytes in the buffer */
213
214 int ndirty; /* Dirty bytes starting at buffer_offset */
215
216 /* Cached stat(2) values. */
217 dev_t st_dev;
218 ino_t st_ino;
219
220 bool unbuffered; /* Buffer should be flushed after each I/O statement. */
221 }
222 unix_stream;
223
224
225 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
226 standard descriptors, returning a non-standard descriptor. If the
227 user specifies that system errors should go to standard output,
228 then closes standard output, we don't want the system errors to a
229 file that has been given file descriptor 1 or 0. We want to send
230 the error to the invalid descriptor. */
231
232 static int
233 fix_fd (int fd)
234 {
235 #ifdef HAVE_DUP
236 int input, output, error;
237
238 input = output = error = 0;
239
240 /* Unix allocates the lowest descriptors first, so a loop is not
241 required, but this order is. */
242 if (fd == STDIN_FILENO)
243 {
244 fd = dup (fd);
245 input = 1;
246 }
247 if (fd == STDOUT_FILENO)
248 {
249 fd = dup (fd);
250 output = 1;
251 }
252 if (fd == STDERR_FILENO)
253 {
254 fd = dup (fd);
255 error = 1;
256 }
257
258 if (input)
259 close (STDIN_FILENO);
260 if (output)
261 close (STDOUT_FILENO);
262 if (error)
263 close (STDERR_FILENO);
264 #endif
265
266 return fd;
267 }
268
269
270 /* If the stream corresponds to a preconnected unit, we flush the
271 corresponding C stream. This is bugware for mixed C-Fortran codes
272 where the C code doesn't flush I/O before returning. */
273 void
274 flush_if_preconnected (stream *s)
275 {
276 int fd;
277
278 fd = ((unix_stream *) s)->fd;
279 if (fd == STDIN_FILENO)
280 fflush (stdin);
281 else if (fd == STDOUT_FILENO)
282 fflush (stdout);
283 else if (fd == STDERR_FILENO)
284 fflush (stderr);
285 }
286
287
288 /********************************************************************
289 Raw I/O functions (read, write, seek, tell, truncate, close).
290
291 These functions wrap the basic POSIX I/O syscalls. Any deviation in
292 semantics is a bug, except the following: write restarts in case
293 of being interrupted by a signal, and as the first argument the
294 functions take the unix_stream struct rather than an integer file
295 descriptor. Also, for POSIX read() and write() a nbyte argument larger
296 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
297 than size_t as for POSIX read/write.
298 *********************************************************************/
299
300 static int
301 raw_flush (unix_stream *s __attribute__ ((unused)))
302 {
303 return 0;
304 }
305
306 /* Write/read at most 2 GB - 4k chunks at a time. Linux never reads or
307 writes more than this, and there are reports that macOS fails for
308 larger than 2 GB as well. */
309 #define MAX_CHUNK 2147479552
310
311 static ssize_t
312 raw_read (unix_stream *s, void *buf, ssize_t nbyte)
313 {
314 /* For read we can't do I/O in a loop like raw_write does, because
315 that will break applications that wait for interactive I/O. We
316 still can loop around EINTR, though. This however causes a
317 problem for large reads which must be chunked, see comment above.
318 So assume that if the size is larger than the chunk size, we're
319 reading from a file and not the terminal. */
320 if (nbyte <= MAX_CHUNK)
321 {
322 while (true)
323 {
324 ssize_t trans = read (s->fd, buf, nbyte);
325 if (trans == -1 && errno == EINTR)
326 continue;
327 return trans;
328 }
329 }
330 else
331 {
332 ssize_t bytes_left = nbyte;
333 char *buf_st = buf;
334 while (bytes_left > 0)
335 {
336 ssize_t to_read = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
337 ssize_t trans = read (s->fd, buf_st, to_read);
338 if (trans == -1)
339 {
340 if (errno == EINTR)
341 continue;
342 else
343 return trans;
344 }
345 buf_st += trans;
346 bytes_left -= trans;
347 }
348 return nbyte - bytes_left;
349 }
350 }
351
352 static ssize_t
353 raw_write (unix_stream *s, const void *buf, ssize_t nbyte)
354 {
355 ssize_t trans, bytes_left;
356 char *buf_st;
357
358 bytes_left = nbyte;
359 buf_st = (char *) buf;
360
361 /* We must write in a loop since some systems don't restart system
362 calls in case of a signal. Also some systems might fail outright
363 if we try to write more than 2 GB in a single syscall, so chunk
364 up large writes. */
365 while (bytes_left > 0)
366 {
367 ssize_t to_write = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
368 trans = write (s->fd, buf_st, to_write);
369 if (trans == -1)
370 {
371 if (errno == EINTR)
372 continue;
373 else
374 return trans;
375 }
376 buf_st += trans;
377 bytes_left -= trans;
378 }
379
380 return nbyte - bytes_left;
381 }
382
383 static gfc_offset
384 raw_seek (unix_stream *s, gfc_offset offset, int whence)
385 {
386 while (true)
387 {
388 gfc_offset off = lseek (s->fd, offset, whence);
389 if (off == (gfc_offset) -1 && errno == EINTR)
390 continue;
391 return off;
392 }
393 }
394
395 static gfc_offset
396 raw_tell (unix_stream *s)
397 {
398 while (true)
399 {
400 gfc_offset off = lseek (s->fd, 0, SEEK_CUR);
401 if (off == (gfc_offset) -1 && errno == EINTR)
402 continue;
403 return off;
404 }
405 }
406
407 static gfc_offset
408 raw_size (unix_stream *s)
409 {
410 struct stat statbuf;
411 if (TEMP_FAILURE_RETRY (fstat (s->fd, &statbuf)) == -1)
412 return -1;
413 if (S_ISREG (statbuf.st_mode))
414 return statbuf.st_size;
415 else
416 return 0;
417 }
418
419 static int
420 raw_truncate (unix_stream *s, gfc_offset length)
421 {
422 #ifdef __MINGW32__
423 HANDLE h;
424 gfc_offset cur;
425
426 if (isatty (s->fd))
427 {
428 errno = EBADF;
429 return -1;
430 }
431 h = (HANDLE) _get_osfhandle (s->fd);
432 if (h == INVALID_HANDLE_VALUE)
433 {
434 errno = EBADF;
435 return -1;
436 }
437 cur = lseek (s->fd, 0, SEEK_CUR);
438 if (cur == -1)
439 return -1;
440 if (lseek (s->fd, length, SEEK_SET) == -1)
441 goto error;
442 if (!SetEndOfFile (h))
443 {
444 errno = EBADF;
445 goto error;
446 }
447 if (lseek (s->fd, cur, SEEK_SET) == -1)
448 return -1;
449 return 0;
450 error:
451 lseek (s->fd, cur, SEEK_SET);
452 return -1;
453 #elif defined HAVE_FTRUNCATE
454 if (TEMP_FAILURE_RETRY (ftruncate (s->fd, length)) == -1)
455 return -1;
456 return 0;
457 #elif defined HAVE_CHSIZE
458 return chsize (s->fd, length);
459 #else
460 runtime_error ("required ftruncate or chsize support not present");
461 return -1;
462 #endif
463 }
464
465 static int
466 raw_close (unix_stream *s)
467 {
468 int retval;
469
470 if (s->fd == -1)
471 retval = -1;
472 else if (s->fd != STDOUT_FILENO
473 && s->fd != STDERR_FILENO
474 && s->fd != STDIN_FILENO)
475 {
476 retval = close (s->fd);
477 /* close() and EINTR is special, as the file descriptor is
478 deallocated before doing anything that might cause the
479 operation to be interrupted. Thus if we get EINTR the best we
480 can do is ignore it and continue (otherwise if we try again
481 the file descriptor may have been allocated again to some
482 other file). */
483 if (retval == -1 && errno == EINTR)
484 retval = errno = 0;
485 }
486 else
487 retval = 0;
488 free (s);
489 return retval;
490 }
491
492 static int
493 raw_markeor (unix_stream *s __attribute__ ((unused)))
494 {
495 return 0;
496 }
497
498 static const struct stream_vtable raw_vtable = {
499 .read = (void *) raw_read,
500 .write = (void *) raw_write,
501 .seek = (void *) raw_seek,
502 .tell = (void *) raw_tell,
503 .size = (void *) raw_size,
504 .trunc = (void *) raw_truncate,
505 .close = (void *) raw_close,
506 .flush = (void *) raw_flush,
507 .markeor = (void *) raw_markeor
508 };
509
510 static int
511 raw_init (unix_stream *s)
512 {
513 s->st.vptr = &raw_vtable;
514
515 s->buffer = NULL;
516 return 0;
517 }
518
519
520 /*********************************************************************
521 Buffered I/O functions. These functions have the same semantics as the
522 raw I/O functions above, except that they are buffered in order to
523 improve performance. The buffer must be flushed when switching from
524 reading to writing and vice versa.
525 *********************************************************************/
526
527 static int
528 buf_flush (unix_stream *s)
529 {
530 int writelen;
531
532 /* Flushing in read mode means discarding read bytes. */
533 s->active = 0;
534
535 if (s->ndirty == 0)
536 return 0;
537
538 if (s->physical_offset != s->buffer_offset
539 && raw_seek (s, s->buffer_offset, SEEK_SET) < 0)
540 return -1;
541
542 writelen = raw_write (s, s->buffer, s->ndirty);
543
544 s->physical_offset = s->buffer_offset + writelen;
545
546 if (s->physical_offset > s->file_length)
547 s->file_length = s->physical_offset;
548
549 s->ndirty -= writelen;
550 if (s->ndirty != 0)
551 return -1;
552
553 return 0;
554 }
555
556 static ssize_t
557 buf_read (unix_stream *s, void *buf, ssize_t nbyte)
558 {
559 if (s->active == 0)
560 s->buffer_offset = s->logical_offset;
561
562 /* Is the data we want in the buffer? */
563 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
564 && s->buffer_offset <= s->logical_offset)
565 {
566 /* When nbyte == 0, buf can be NULL which would lead to undefined
567 behavior if we called memcpy(). */
568 if (nbyte != 0)
569 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
570 nbyte);
571 }
572 else
573 {
574 /* First copy the active bytes if applicable, then read the rest
575 either directly or filling the buffer. */
576 char *p;
577 int nread = 0;
578 ssize_t to_read, did_read;
579 gfc_offset new_logical;
580
581 p = (char *) buf;
582 if (s->logical_offset >= s->buffer_offset
583 && s->buffer_offset + s->active >= s->logical_offset)
584 {
585 nread = s->active - (s->logical_offset - s->buffer_offset);
586 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
587 nread);
588 p += nread;
589 }
590 /* At this point we consider all bytes in the buffer discarded. */
591 to_read = nbyte - nread;
592 new_logical = s->logical_offset + nread;
593 if (s->physical_offset != new_logical
594 && raw_seek (s, new_logical, SEEK_SET) < 0)
595 return -1;
596 s->buffer_offset = s->physical_offset = new_logical;
597 if (to_read <= s->buffer_size/2)
598 {
599 did_read = raw_read (s, s->buffer, s->buffer_size);
600 if (likely (did_read >= 0))
601 {
602 s->physical_offset += did_read;
603 s->active = did_read;
604 did_read = (did_read > to_read) ? to_read : did_read;
605 memcpy (p, s->buffer, did_read);
606 }
607 else
608 return did_read;
609 }
610 else
611 {
612 did_read = raw_read (s, p, to_read);
613 if (likely (did_read >= 0))
614 {
615 s->physical_offset += did_read;
616 s->active = 0;
617 }
618 else
619 return did_read;
620 }
621 nbyte = did_read + nread;
622 }
623 s->logical_offset += nbyte;
624 return nbyte;
625 }
626
627 static ssize_t
628 buf_write (unix_stream *s, const void *buf, ssize_t nbyte)
629 {
630 if (nbyte == 0)
631 return 0;
632
633 if (s->ndirty == 0)
634 s->buffer_offset = s->logical_offset;
635
636 /* Does the data fit into the buffer? As a special case, if the
637 buffer is empty and the request is bigger than s->buffer_size/2,
638 write directly. This avoids the case where the buffer would have
639 to be flushed at every write. */
640 if (!(s->ndirty == 0 && nbyte > s->buffer_size/2)
641 && s->logical_offset + nbyte <= s->buffer_offset + s->buffer_size
642 && s->buffer_offset <= s->logical_offset
643 && s->buffer_offset + s->ndirty >= s->logical_offset)
644 {
645 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
646 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
647 if (nd > s->ndirty)
648 s->ndirty = nd;
649 }
650 else
651 {
652 /* Flush, and either fill the buffer with the new data, or if
653 the request is bigger than the buffer size, write directly
654 bypassing the buffer. */
655 buf_flush (s);
656 if (nbyte <= s->buffer_size/2)
657 {
658 memcpy (s->buffer, buf, nbyte);
659 s->buffer_offset = s->logical_offset;
660 s->ndirty += nbyte;
661 }
662 else
663 {
664 if (s->physical_offset != s->logical_offset)
665 {
666 if (raw_seek (s, s->logical_offset, SEEK_SET) < 0)
667 return -1;
668 s->physical_offset = s->logical_offset;
669 }
670
671 nbyte = raw_write (s, buf, nbyte);
672 s->physical_offset += nbyte;
673 }
674 }
675 s->logical_offset += nbyte;
676 if (s->logical_offset > s->file_length)
677 s->file_length = s->logical_offset;
678 return nbyte;
679 }
680
681
682 /* "Unbuffered" really means I/O statement buffering. For formatted
683 I/O, the fbuf manages this, and then uses raw I/O. For unformatted
684 I/O, buffered I/O is used, and the buffer is flushed at the end of
685 each I/O statement, where this function is called. Alternatively,
686 the buffer is flushed at the end of the record if the buffer is
687 more than half full; this prevents needless seeking back and forth
688 when writing sequential unformatted. */
689
690 static int
691 buf_markeor (unix_stream *s)
692 {
693 if (s->unbuffered || s->ndirty >= s->buffer_size / 2)
694 return buf_flush (s);
695 return 0;
696 }
697
698 static gfc_offset
699 buf_seek (unix_stream *s, gfc_offset offset, int whence)
700 {
701 switch (whence)
702 {
703 case SEEK_SET:
704 break;
705 case SEEK_CUR:
706 offset += s->logical_offset;
707 break;
708 case SEEK_END:
709 offset += s->file_length;
710 break;
711 default:
712 return -1;
713 }
714 if (offset < 0)
715 {
716 errno = EINVAL;
717 return -1;
718 }
719 s->logical_offset = offset;
720 return offset;
721 }
722
723 static gfc_offset
724 buf_tell (unix_stream *s)
725 {
726 return buf_seek (s, 0, SEEK_CUR);
727 }
728
729 static gfc_offset
730 buf_size (unix_stream *s)
731 {
732 return s->file_length;
733 }
734
735 static int
736 buf_truncate (unix_stream *s, gfc_offset length)
737 {
738 int r;
739
740 if (buf_flush (s) != 0)
741 return -1;
742 r = raw_truncate (s, length);
743 if (r == 0)
744 s->file_length = length;
745 return r;
746 }
747
748 static int
749 buf_close (unix_stream *s)
750 {
751 if (buf_flush (s) != 0)
752 return -1;
753 free (s->buffer);
754 return raw_close (s);
755 }
756
757 static const struct stream_vtable buf_vtable = {
758 .read = (void *) buf_read,
759 .write = (void *) buf_write,
760 .seek = (void *) buf_seek,
761 .tell = (void *) buf_tell,
762 .size = (void *) buf_size,
763 .trunc = (void *) buf_truncate,
764 .close = (void *) buf_close,
765 .flush = (void *) buf_flush,
766 .markeor = (void *) buf_markeor
767 };
768
769 static int
770 buf_init (unix_stream *s, bool unformatted)
771 {
772 s->st.vptr = &buf_vtable;
773
774 /* Try to guess a good value for the buffer size. For formatted
775 I/O, we use so many CPU cycles converting the data that there is
776 more sense in converving memory and especially cache. For
777 unformatted, a bigger block can have a large impact in some
778 environments. */
779
780 if (unformatted)
781 {
782 if (options.unformatted_buffer_size > 0)
783 s->buffer_size = options.unformatted_buffer_size;
784 else
785 s->buffer_size = UNFORMATTED_BUFFER_SIZE_DEFAULT;
786 }
787 else
788 {
789 if (options.formatted_buffer_size > 0)
790 s->buffer_size = options.formatted_buffer_size;
791 else
792 s->buffer_size = FORMATTED_BUFFER_SIZE_DEFAULT;
793 }
794
795 s->buffer = xmalloc (s->buffer_size);
796 return 0;
797 }
798
799
800 /*********************************************************************
801 memory stream functions - These are used for internal files
802
803 The idea here is that a single stream structure is created and all
804 requests must be satisfied from it. The location and size of the
805 buffer is the character variable supplied to the READ or WRITE
806 statement.
807
808 *********************************************************************/
809
810 char *
811 mem_alloc_r (stream *strm, size_t *len)
812 {
813 unix_stream *s = (unix_stream *) strm;
814 gfc_offset n;
815 gfc_offset where = s->logical_offset;
816
817 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
818 return NULL;
819
820 n = s->buffer_offset + s->active - where;
821 if ((gfc_offset) *len > n)
822 *len = n;
823
824 s->logical_offset = where + *len;
825
826 return s->buffer + (where - s->buffer_offset);
827 }
828
829
830 char *
831 mem_alloc_r4 (stream *strm, size_t *len)
832 {
833 unix_stream *s = (unix_stream *) strm;
834 gfc_offset n;
835 gfc_offset where = s->logical_offset;
836
837 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
838 return NULL;
839
840 n = s->buffer_offset + s->active - where;
841 if ((gfc_offset) *len > n)
842 *len = n;
843
844 s->logical_offset = where + *len;
845
846 return s->buffer + (where - s->buffer_offset) * 4;
847 }
848
849
850 char *
851 mem_alloc_w (stream *strm, size_t *len)
852 {
853 unix_stream *s = (unix_stream *)strm;
854 gfc_offset m;
855 gfc_offset where = s->logical_offset;
856
857 m = where + *len;
858
859 if (where < s->buffer_offset)
860 return NULL;
861
862 if (m > s->file_length)
863 return NULL;
864
865 s->logical_offset = m;
866
867 return s->buffer + (where - s->buffer_offset);
868 }
869
870
871 gfc_char4_t *
872 mem_alloc_w4 (stream *strm, size_t *len)
873 {
874 unix_stream *s = (unix_stream *)strm;
875 gfc_offset m;
876 gfc_offset where = s->logical_offset;
877 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
878
879 m = where + *len;
880
881 if (where < s->buffer_offset)
882 return NULL;
883
884 if (m > s->file_length)
885 return NULL;
886
887 s->logical_offset = m;
888 return &result[where - s->buffer_offset];
889 }
890
891
892 /* Stream read function for character(kind=1) internal units. */
893
894 static ssize_t
895 mem_read (stream *s, void *buf, ssize_t nbytes)
896 {
897 void *p;
898 size_t nb = nbytes;
899
900 p = mem_alloc_r (s, &nb);
901 if (p)
902 {
903 memcpy (buf, p, nb);
904 return (ssize_t) nb;
905 }
906 else
907 return 0;
908 }
909
910
911 /* Stream read function for chracter(kind=4) internal units. */
912
913 static ssize_t
914 mem_read4 (stream *s, void *buf, ssize_t nbytes)
915 {
916 void *p;
917 size_t nb = nbytes;
918
919 p = mem_alloc_r4 (s, &nb);
920 if (p)
921 {
922 memcpy (buf, p, nb * 4);
923 return (ssize_t) nb;
924 }
925 else
926 return 0;
927 }
928
929
930 /* Stream write function for character(kind=1) internal units. */
931
932 static ssize_t
933 mem_write (stream *s, const void *buf, ssize_t nbytes)
934 {
935 void *p;
936 size_t nb = nbytes;
937
938 p = mem_alloc_w (s, &nb);
939 if (p)
940 {
941 memcpy (p, buf, nb);
942 return (ssize_t) nb;
943 }
944 else
945 return 0;
946 }
947
948
949 /* Stream write function for character(kind=4) internal units. */
950
951 static ssize_t
952 mem_write4 (stream *s, const void *buf, ssize_t nwords)
953 {
954 gfc_char4_t *p;
955 size_t nw = nwords;
956
957 p = mem_alloc_w4 (s, &nw);
958 if (p)
959 {
960 while (nw--)
961 *p++ = (gfc_char4_t) *((char *) buf);
962 return nwords;
963 }
964 else
965 return 0;
966 }
967
968
969 static gfc_offset
970 mem_seek (stream *strm, gfc_offset offset, int whence)
971 {
972 unix_stream *s = (unix_stream *)strm;
973 switch (whence)
974 {
975 case SEEK_SET:
976 break;
977 case SEEK_CUR:
978 offset += s->logical_offset;
979 break;
980 case SEEK_END:
981 offset += s->file_length;
982 break;
983 default:
984 return -1;
985 }
986
987 /* Note that for internal array I/O it's actually possible to have a
988 negative offset, so don't check for that. */
989 if (offset > s->file_length)
990 {
991 errno = EINVAL;
992 return -1;
993 }
994
995 s->logical_offset = offset;
996
997 /* Returning < 0 is the error indicator for sseek(), so return 0 if
998 offset is negative. Thus if the return value is 0, the caller
999 has to use stell() to get the real value of logical_offset. */
1000 if (offset >= 0)
1001 return offset;
1002 return 0;
1003 }
1004
1005
1006 static gfc_offset
1007 mem_tell (stream *s)
1008 {
1009 return ((unix_stream *)s)->logical_offset;
1010 }
1011
1012
1013 static int
1014 mem_truncate (unix_stream *s __attribute__ ((unused)),
1015 gfc_offset length __attribute__ ((unused)))
1016 {
1017 return 0;
1018 }
1019
1020
1021 static int
1022 mem_flush (unix_stream *s __attribute__ ((unused)))
1023 {
1024 return 0;
1025 }
1026
1027
1028 static int
1029 mem_close (unix_stream *s)
1030 {
1031 if (s)
1032 free (s);
1033 return 0;
1034 }
1035
1036 static const struct stream_vtable mem_vtable = {
1037 .read = (void *) mem_read,
1038 .write = (void *) mem_write,
1039 .seek = (void *) mem_seek,
1040 .tell = (void *) mem_tell,
1041 /* buf_size is not a typo, we just reuse an identical
1042 implementation. */
1043 .size = (void *) buf_size,
1044 .trunc = (void *) mem_truncate,
1045 .close = (void *) mem_close,
1046 .flush = (void *) mem_flush,
1047 .markeor = (void *) raw_markeor
1048 };
1049
1050 static const struct stream_vtable mem4_vtable = {
1051 .read = (void *) mem_read4,
1052 .write = (void *) mem_write4,
1053 .seek = (void *) mem_seek,
1054 .tell = (void *) mem_tell,
1055 /* buf_size is not a typo, we just reuse an identical
1056 implementation. */
1057 .size = (void *) buf_size,
1058 .trunc = (void *) mem_truncate,
1059 .close = (void *) mem_close,
1060 .flush = (void *) mem_flush,
1061 .markeor = (void *) raw_markeor
1062 };
1063
1064 /*********************************************************************
1065 Public functions -- A reimplementation of this module needs to
1066 define functional equivalents of the following.
1067 *********************************************************************/
1068
1069 /* open_internal()-- Returns a stream structure from a character(kind=1)
1070 internal file */
1071
1072 stream *
1073 open_internal (char *base, size_t length, gfc_offset offset)
1074 {
1075 unix_stream *s;
1076
1077 s = xcalloc (1, sizeof (unix_stream));
1078
1079 s->buffer = base;
1080 s->buffer_offset = offset;
1081
1082 s->active = s->file_length = length;
1083
1084 s->st.vptr = &mem_vtable;
1085
1086 return (stream *) s;
1087 }
1088
1089 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1090 internal file */
1091
1092 stream *
1093 open_internal4 (char *base, size_t length, gfc_offset offset)
1094 {
1095 unix_stream *s;
1096
1097 s = xcalloc (1, sizeof (unix_stream));
1098
1099 s->buffer = base;
1100 s->buffer_offset = offset;
1101
1102 s->active = s->file_length = length * sizeof (gfc_char4_t);
1103
1104 s->st.vptr = &mem4_vtable;
1105
1106 return (stream *)s;
1107 }
1108
1109
1110 /* fd_to_stream()-- Given an open file descriptor, build a stream
1111 around it. */
1112
1113 static stream *
1114 fd_to_stream (int fd, bool unformatted)
1115 {
1116 struct stat statbuf;
1117 unix_stream *s;
1118
1119 s = xcalloc (1, sizeof (unix_stream));
1120
1121 s->fd = fd;
1122
1123 /* Get the current length of the file. */
1124
1125 if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1126 {
1127 s->st_dev = s->st_ino = -1;
1128 s->file_length = 0;
1129 if (errno == EBADF)
1130 s->fd = -1;
1131 raw_init (s);
1132 return (stream *) s;
1133 }
1134
1135 s->st_dev = statbuf.st_dev;
1136 s->st_ino = statbuf.st_ino;
1137 s->file_length = statbuf.st_size;
1138
1139 /* Only use buffered IO for regular files. */
1140 if (S_ISREG (statbuf.st_mode)
1141 && !options.all_unbuffered
1142 && !(options.unbuffered_preconnected &&
1143 (s->fd == STDIN_FILENO
1144 || s->fd == STDOUT_FILENO
1145 || s->fd == STDERR_FILENO)))
1146 buf_init (s, unformatted);
1147 else
1148 {
1149 if (unformatted)
1150 {
1151 s->unbuffered = true;
1152 buf_init (s, unformatted);
1153 }
1154 else
1155 raw_init (s);
1156 }
1157
1158 return (stream *) s;
1159 }
1160
1161
1162 /* Given the Fortran unit number, convert it to a C file descriptor. */
1163
1164 int
1165 unit_to_fd (int unit)
1166 {
1167 gfc_unit *us;
1168 int fd;
1169
1170 us = find_unit (unit);
1171 if (us == NULL)
1172 return -1;
1173
1174 fd = ((unix_stream *) us->s)->fd;
1175 unlock_unit (us);
1176 return fd;
1177 }
1178
1179
1180 /* Set the close-on-exec flag for an existing fd, if the system
1181 supports such. */
1182
1183 static void __attribute__ ((unused))
1184 set_close_on_exec (int fd __attribute__ ((unused)))
1185 {
1186 /* Mingw does not define F_SETFD. */
1187 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1188 if (fd >= 0)
1189 fcntl(fd, F_SETFD, FD_CLOEXEC);
1190 #endif
1191 }
1192
1193
1194 /* Helper function for tempfile(). Tries to open a temporary file in
1195 the directory specified by tempdir. If successful, the file name is
1196 stored in fname and the descriptor returned. Returns -1 on
1197 failure. */
1198
1199 static int
1200 tempfile_open (const char *tempdir, char **fname)
1201 {
1202 int fd;
1203 const char *slash = "/";
1204 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1205 mode_t mode_mask;
1206 #endif
1207
1208 if (!tempdir)
1209 return -1;
1210
1211 /* Check for the special case that tempdir ends with a slash or
1212 backslash. */
1213 size_t tempdirlen = strlen (tempdir);
1214 if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1215 #ifdef __MINGW32__
1216 || tempdir[tempdirlen - 1] == '\\'
1217 #endif
1218 )
1219 slash = "";
1220
1221 /* Take care that the template is longer in the mktemp() branch. */
1222 char *template = xmalloc (tempdirlen + 23);
1223
1224 #ifdef HAVE_MKSTEMP
1225 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1226 tempdir, slash);
1227
1228 #ifdef HAVE_UMASK
1229 /* Temporarily set the umask such that the file has 0600 permissions. */
1230 mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1231 #endif
1232
1233 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1234 TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1235 #else
1236 TEMP_FAILURE_RETRY (fd = mkstemp (template));
1237 set_close_on_exec (fd);
1238 #endif
1239
1240 #ifdef HAVE_UMASK
1241 (void) umask (mode_mask);
1242 #endif
1243
1244 #else /* HAVE_MKSTEMP */
1245 fd = -1;
1246 int count = 0;
1247 size_t slashlen = strlen (slash);
1248 int flags = O_RDWR | O_CREAT | O_EXCL;
1249 #if defined(HAVE_CRLF) && defined(O_BINARY)
1250 flags |= O_BINARY;
1251 #endif
1252 #ifdef O_CLOEXEC
1253 flags |= O_CLOEXEC;
1254 #endif
1255 do
1256 {
1257 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1258 tempdir, slash);
1259 if (count > 0)
1260 {
1261 int c = count;
1262 template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1263 c /= 26;
1264 template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1265 c /= 26;
1266 template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1267 if (c >= 26)
1268 break;
1269 }
1270
1271 if (!mktemp (template))
1272 {
1273 errno = EEXIST;
1274 count++;
1275 continue;
1276 }
1277
1278 TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1279 }
1280 while (fd == -1 && errno == EEXIST);
1281 #ifndef O_CLOEXEC
1282 set_close_on_exec (fd);
1283 #endif
1284 #endif /* HAVE_MKSTEMP */
1285
1286 *fname = template;
1287 return fd;
1288 }
1289
1290
1291 /* tempfile()-- Generate a temporary filename for a scratch file and
1292 open it. mkstemp() opens the file for reading and writing, but the
1293 library mode prevents anything that is not allowed. The descriptor
1294 is returned, which is -1 on error. The template is pointed to by
1295 opp->file, which is copied into the unit structure
1296 and freed later. */
1297
1298 static int
1299 tempfile (st_parameter_open *opp)
1300 {
1301 const char *tempdir;
1302 char *fname;
1303 int fd = -1;
1304
1305 tempdir = secure_getenv ("TMPDIR");
1306 fd = tempfile_open (tempdir, &fname);
1307 #ifdef __MINGW32__
1308 if (fd == -1)
1309 {
1310 char buffer[MAX_PATH + 1];
1311 DWORD ret;
1312 ret = GetTempPath (MAX_PATH, buffer);
1313 /* If we are not able to get a temp-directory, we use
1314 current directory. */
1315 if (ret > MAX_PATH || !ret)
1316 buffer[0] = 0;
1317 else
1318 buffer[ret] = 0;
1319 tempdir = strdup (buffer);
1320 fd = tempfile_open (tempdir, &fname);
1321 }
1322 #elif defined(__CYGWIN__)
1323 if (fd == -1)
1324 {
1325 tempdir = secure_getenv ("TMP");
1326 fd = tempfile_open (tempdir, &fname);
1327 }
1328 if (fd == -1)
1329 {
1330 tempdir = secure_getenv ("TEMP");
1331 fd = tempfile_open (tempdir, &fname);
1332 }
1333 #endif
1334 if (fd == -1)
1335 fd = tempfile_open (P_tmpdir, &fname);
1336
1337 opp->file = fname;
1338 opp->file_len = strlen (fname); /* Don't include trailing nul */
1339
1340 return fd;
1341 }
1342
1343
1344 /* regular_file2()-- Open a regular file.
1345 Change flags->action if it is ACTION_UNSPECIFIED on entry,
1346 unless an error occurs.
1347 Returns the descriptor, which is less than zero on error. */
1348
1349 static int
1350 regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1351 {
1352 int mode;
1353 int rwflag;
1354 int crflag, crflag2;
1355 int fd;
1356
1357 #ifdef __CYGWIN__
1358 if (opp->file_len == 7)
1359 {
1360 if (strncmp (path, "CONOUT$", 7) == 0
1361 || strncmp (path, "CONERR$", 7) == 0)
1362 {
1363 fd = open ("/dev/conout", O_WRONLY);
1364 flags->action = ACTION_WRITE;
1365 return fd;
1366 }
1367 }
1368
1369 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1370 {
1371 fd = open ("/dev/conin", O_RDONLY);
1372 flags->action = ACTION_READ;
1373 return fd;
1374 }
1375 #endif
1376
1377
1378 #ifdef __MINGW32__
1379 if (opp->file_len == 7)
1380 {
1381 if (strncmp (path, "CONOUT$", 7) == 0
1382 || strncmp (path, "CONERR$", 7) == 0)
1383 {
1384 fd = open ("CONOUT$", O_WRONLY);
1385 flags->action = ACTION_WRITE;
1386 return fd;
1387 }
1388 }
1389
1390 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1391 {
1392 fd = open ("CONIN$", O_RDONLY);
1393 flags->action = ACTION_READ;
1394 return fd;
1395 }
1396 #endif
1397
1398 switch (flags->action)
1399 {
1400 case ACTION_READ:
1401 rwflag = O_RDONLY;
1402 break;
1403
1404 case ACTION_WRITE:
1405 rwflag = O_WRONLY;
1406 break;
1407
1408 case ACTION_READWRITE:
1409 case ACTION_UNSPECIFIED:
1410 rwflag = O_RDWR;
1411 break;
1412
1413 default:
1414 internal_error (&opp->common, "regular_file(): Bad action");
1415 }
1416
1417 switch (flags->status)
1418 {
1419 case STATUS_NEW:
1420 crflag = O_CREAT | O_EXCL;
1421 break;
1422
1423 case STATUS_OLD: /* open will fail if the file does not exist*/
1424 crflag = 0;
1425 break;
1426
1427 case STATUS_UNKNOWN:
1428 if (rwflag == O_RDONLY)
1429 crflag = 0;
1430 else
1431 crflag = O_CREAT;
1432 break;
1433
1434 case STATUS_REPLACE:
1435 crflag = O_CREAT | O_TRUNC;
1436 break;
1437
1438 default:
1439 /* Note: STATUS_SCRATCH is handled by tempfile () and should
1440 never be seen here. */
1441 internal_error (&opp->common, "regular_file(): Bad status");
1442 }
1443
1444 /* rwflag |= O_LARGEFILE; */
1445
1446 #if defined(HAVE_CRLF) && defined(O_BINARY)
1447 crflag |= O_BINARY;
1448 #endif
1449
1450 #ifdef O_CLOEXEC
1451 crflag |= O_CLOEXEC;
1452 #endif
1453
1454 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1455 TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1456 if (flags->action != ACTION_UNSPECIFIED)
1457 return fd;
1458
1459 if (fd >= 0)
1460 {
1461 flags->action = ACTION_READWRITE;
1462 return fd;
1463 }
1464 if (errno != EACCES && errno != EPERM && errno != EROFS)
1465 return fd;
1466
1467 /* retry for read-only access */
1468 rwflag = O_RDONLY;
1469 if (flags->status == STATUS_UNKNOWN)
1470 crflag2 = crflag & ~(O_CREAT);
1471 else
1472 crflag2 = crflag;
1473 TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1474 if (fd >=0)
1475 {
1476 flags->action = ACTION_READ;
1477 return fd; /* success */
1478 }
1479
1480 if (errno != EACCES && errno != EPERM && errno != ENOENT)
1481 return fd; /* failure */
1482
1483 /* retry for write-only access */
1484 rwflag = O_WRONLY;
1485 TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1486 if (fd >=0)
1487 {
1488 flags->action = ACTION_WRITE;
1489 return fd; /* success */
1490 }
1491 return fd; /* failure */
1492 }
1493
1494
1495 /* Lock the file, if necessary, based on SHARE flags. */
1496
1497 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1498 static int
1499 open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1500 {
1501 int r = 0;
1502 struct flock f;
1503 if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1504 return 0;
1505
1506 f.l_start = 0;
1507 f.l_len = 0;
1508 f.l_whence = SEEK_SET;
1509
1510 switch (flags->share)
1511 {
1512 case SHARE_DENYNONE:
1513 f.l_type = F_RDLCK;
1514 r = fcntl (fd, F_SETLK, &f);
1515 break;
1516 case SHARE_DENYRW:
1517 /* Must be writable to hold write lock. */
1518 if (flags->action == ACTION_READ)
1519 {
1520 generate_error (&opp->common, LIBERROR_BAD_ACTION,
1521 "Cannot set write lock on file opened for READ");
1522 return -1;
1523 }
1524 f.l_type = F_WRLCK;
1525 r = fcntl (fd, F_SETLK, &f);
1526 break;
1527 case SHARE_UNSPECIFIED:
1528 default:
1529 break;
1530 }
1531
1532 return r;
1533 }
1534 #else
1535 static int
1536 open_share (st_parameter_open *opp __attribute__ ((unused)),
1537 int fd __attribute__ ((unused)),
1538 unit_flags *flags __attribute__ ((unused)))
1539 {
1540 return 0;
1541 }
1542 #endif /* defined(HAVE_FCNTL) ... */
1543
1544
1545 /* Wrapper around regular_file2, to make sure we free the path after
1546 we're done. */
1547
1548 static int
1549 regular_file (st_parameter_open *opp, unit_flags *flags)
1550 {
1551 char *path = fc_strdup (opp->file, opp->file_len);
1552 int fd = regular_file2 (path, opp, flags);
1553 free (path);
1554 return fd;
1555 }
1556
1557 /* open_external()-- Open an external file, unix specific version.
1558 Change flags->action if it is ACTION_UNSPECIFIED on entry.
1559 Returns NULL on operating system error. */
1560
1561 stream *
1562 open_external (st_parameter_open *opp, unit_flags *flags)
1563 {
1564 int fd;
1565
1566 if (flags->status == STATUS_SCRATCH)
1567 {
1568 fd = tempfile (opp);
1569 if (flags->action == ACTION_UNSPECIFIED)
1570 flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1571
1572 #if HAVE_UNLINK_OPEN_FILE
1573 /* We can unlink scratch files now and it will go away when closed. */
1574 if (fd >= 0)
1575 unlink (opp->file);
1576 #endif
1577 }
1578 else
1579 {
1580 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1581 if it succeeds */
1582 fd = regular_file (opp, flags);
1583 #ifndef O_CLOEXEC
1584 set_close_on_exec (fd);
1585 #endif
1586 }
1587
1588 if (fd < 0)
1589 return NULL;
1590 fd = fix_fd (fd);
1591
1592 if (open_share (opp, fd, flags) < 0)
1593 return NULL;
1594
1595 return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1596 }
1597
1598
1599 /* input_stream()-- Return a stream pointer to the default input stream.
1600 Called on initialization. */
1601
1602 stream *
1603 input_stream (void)
1604 {
1605 return fd_to_stream (STDIN_FILENO, false);
1606 }
1607
1608
1609 /* output_stream()-- Return a stream pointer to the default output stream.
1610 Called on initialization. */
1611
1612 stream *
1613 output_stream (void)
1614 {
1615 stream *s;
1616
1617 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1618 setmode (STDOUT_FILENO, O_BINARY);
1619 #endif
1620
1621 s = fd_to_stream (STDOUT_FILENO, false);
1622 return s;
1623 }
1624
1625
1626 /* error_stream()-- Return a stream pointer to the default error stream.
1627 Called on initialization. */
1628
1629 stream *
1630 error_stream (void)
1631 {
1632 stream *s;
1633
1634 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1635 setmode (STDERR_FILENO, O_BINARY);
1636 #endif
1637
1638 s = fd_to_stream (STDERR_FILENO, false);
1639 return s;
1640 }
1641
1642
1643 /* compare_file_filename()-- Given an open stream and a fortran string
1644 that is a filename, figure out if the file is the same as the
1645 filename. */
1646
1647 int
1648 compare_file_filename (gfc_unit *u, const char *name, gfc_charlen_type len)
1649 {
1650 struct stat st;
1651 int ret;
1652 #ifdef HAVE_WORKING_STAT
1653 unix_stream *s;
1654 #else
1655 # ifdef __MINGW32__
1656 uint64_t id1, id2;
1657 # endif
1658 #endif
1659
1660 char *path = fc_strdup (name, len);
1661
1662 /* If the filename doesn't exist, then there is no match with the
1663 existing file. */
1664
1665 if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1666 {
1667 ret = 0;
1668 goto done;
1669 }
1670
1671 #ifdef HAVE_WORKING_STAT
1672 s = (unix_stream *) (u->s);
1673 ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1674 goto done;
1675 #else
1676
1677 # ifdef __MINGW32__
1678 /* We try to match files by a unique ID. On some filesystems (network
1679 fs and FAT), we can't generate this unique ID, and will simply compare
1680 filenames. */
1681 id1 = id_from_path (path);
1682 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1683 if (id1 || id2)
1684 {
1685 ret = (id1 == id2);
1686 goto done;
1687 }
1688 # endif
1689 if (u->filename)
1690 ret = (strcmp(path, u->filename) == 0);
1691 else
1692 ret = 0;
1693 #endif
1694 done:
1695 free (path);
1696 return ret;
1697 }
1698
1699
1700 #ifdef HAVE_WORKING_STAT
1701 # define FIND_FILE0_DECL struct stat *st
1702 # define FIND_FILE0_ARGS st
1703 #else
1704 # define FIND_FILE0_DECL uint64_t id, const char *path
1705 # define FIND_FILE0_ARGS id, path
1706 #endif
1707
1708 /* find_file0()-- Recursive work function for find_file() */
1709
1710 static gfc_unit *
1711 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1712 {
1713 gfc_unit *v;
1714 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1715 uint64_t id1;
1716 #endif
1717
1718 if (u == NULL)
1719 return NULL;
1720
1721 #ifdef HAVE_WORKING_STAT
1722 if (u->s != NULL)
1723 {
1724 unix_stream *s = (unix_stream *) (u->s);
1725 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1726 return u;
1727 }
1728 #else
1729 # ifdef __MINGW32__
1730 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1731 {
1732 if (id == id1)
1733 return u;
1734 }
1735 else
1736 # endif
1737 if (u->filename && strcmp (u->filename, path) == 0)
1738 return u;
1739 #endif
1740
1741 v = find_file0 (u->left, FIND_FILE0_ARGS);
1742 if (v != NULL)
1743 return v;
1744
1745 v = find_file0 (u->right, FIND_FILE0_ARGS);
1746 if (v != NULL)
1747 return v;
1748
1749 return NULL;
1750 }
1751
1752
1753 /* find_file()-- Take the current filename and see if there is a unit
1754 that has the file already open. Returns a pointer to the unit if so. */
1755
1756 gfc_unit *
1757 find_file (const char *file, gfc_charlen_type file_len)
1758 {
1759 struct stat st[1];
1760 gfc_unit *u;
1761 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1762 uint64_t id = 0ULL;
1763 #endif
1764
1765 char *path = fc_strdup (file, file_len);
1766
1767 if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1768 {
1769 u = NULL;
1770 goto done;
1771 }
1772
1773 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1774 id = id_from_path (path);
1775 #endif
1776
1777 LOCK (&unit_lock);
1778 retry:
1779 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1780 if (u != NULL)
1781 {
1782 /* Fast path. */
1783 if (! __gthread_mutex_trylock (&u->lock))
1784 {
1785 /* assert (u->closed == 0); */
1786 UNLOCK (&unit_lock);
1787 goto done;
1788 }
1789
1790 inc_waiting_locked (u);
1791 }
1792 UNLOCK (&unit_lock);
1793 if (u != NULL)
1794 {
1795 LOCK (&u->lock);
1796 if (u->closed)
1797 {
1798 LOCK (&unit_lock);
1799 UNLOCK (&u->lock);
1800 if (predec_waiting_locked (u) == 0)
1801 free (u);
1802 goto retry;
1803 }
1804
1805 dec_waiting_unlocked (u);
1806 }
1807 done:
1808 free (path);
1809 return u;
1810 }
1811
1812 static gfc_unit *
1813 flush_all_units_1 (gfc_unit *u, int min_unit)
1814 {
1815 while (u != NULL)
1816 {
1817 if (u->unit_number > min_unit)
1818 {
1819 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1820 if (r != NULL)
1821 return r;
1822 }
1823 if (u->unit_number >= min_unit)
1824 {
1825 if (__gthread_mutex_trylock (&u->lock))
1826 return u;
1827 if (u->s)
1828 sflush (u->s);
1829 UNLOCK (&u->lock);
1830 }
1831 u = u->right;
1832 }
1833 return NULL;
1834 }
1835
1836 void
1837 flush_all_units (void)
1838 {
1839 gfc_unit *u;
1840 int min_unit = 0;
1841
1842 LOCK (&unit_lock);
1843 do
1844 {
1845 u = flush_all_units_1 (unit_root, min_unit);
1846 if (u != NULL)
1847 inc_waiting_locked (u);
1848 UNLOCK (&unit_lock);
1849 if (u == NULL)
1850 return;
1851
1852 LOCK (&u->lock);
1853
1854 min_unit = u->unit_number + 1;
1855
1856 if (u->closed == 0)
1857 {
1858 sflush (u->s);
1859 LOCK (&unit_lock);
1860 UNLOCK (&u->lock);
1861 (void) predec_waiting_locked (u);
1862 }
1863 else
1864 {
1865 LOCK (&unit_lock);
1866 UNLOCK (&u->lock);
1867 if (predec_waiting_locked (u) == 0)
1868 free (u);
1869 }
1870 }
1871 while (1);
1872 }
1873
1874
1875 /* Unlock the unit if necessary, based on SHARE flags. */
1876
1877 int
1878 close_share (gfc_unit *u __attribute__ ((unused)))
1879 {
1880 int r = 0;
1881 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1882 unix_stream *s = (unix_stream *) u->s;
1883 int fd = s->fd;
1884 struct flock f;
1885
1886 switch (u->flags.share)
1887 {
1888 case SHARE_DENYRW:
1889 case SHARE_DENYNONE:
1890 if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1891 {
1892 f.l_start = 0;
1893 f.l_len = 0;
1894 f.l_whence = SEEK_SET;
1895 f.l_type = F_UNLCK;
1896 r = fcntl (fd, F_SETLK, &f);
1897 }
1898 break;
1899 case SHARE_UNSPECIFIED:
1900 default:
1901 break;
1902 }
1903
1904 #endif
1905 return r;
1906 }
1907
1908
1909 /* file_exists()-- Returns nonzero if the current filename exists on
1910 the system */
1911
1912 int
1913 file_exists (const char *file, gfc_charlen_type file_len)
1914 {
1915 char *path = fc_strdup (file, file_len);
1916 int res = !(access (path, F_OK));
1917 free (path);
1918 return res;
1919 }
1920
1921
1922 /* file_size()-- Returns the size of the file. */
1923
1924 GFC_IO_INT
1925 file_size (const char *file, gfc_charlen_type file_len)
1926 {
1927 char *path = fc_strdup (file, file_len);
1928 struct stat statbuf;
1929 int err;
1930 TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1931 free (path);
1932 if (err == -1)
1933 return -1;
1934 return (GFC_IO_INT) statbuf.st_size;
1935 }
1936
1937 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1938
1939 /* inquire_sequential()-- Given a fortran string, determine if the
1940 file is suitable for sequential access. Returns a C-style
1941 string. */
1942
1943 const char *
1944 inquire_sequential (const char *string, gfc_charlen_type len)
1945 {
1946 struct stat statbuf;
1947
1948 if (string == NULL)
1949 return unknown;
1950
1951 char *path = fc_strdup (string, len);
1952 int err;
1953 TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1954 free (path);
1955 if (err == -1)
1956 return unknown;
1957
1958 if (S_ISREG (statbuf.st_mode) ||
1959 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1960 return unknown;
1961
1962 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1963 return no;
1964
1965 return unknown;
1966 }
1967
1968
1969 /* inquire_direct()-- Given a fortran string, determine if the file is
1970 suitable for direct access. Returns a C-style string. */
1971
1972 const char *
1973 inquire_direct (const char *string, gfc_charlen_type len)
1974 {
1975 struct stat statbuf;
1976
1977 if (string == NULL)
1978 return unknown;
1979
1980 char *path = fc_strdup (string, len);
1981 int err;
1982 TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1983 free (path);
1984 if (err == -1)
1985 return unknown;
1986
1987 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1988 return unknown;
1989
1990 if (S_ISDIR (statbuf.st_mode) ||
1991 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1992 return no;
1993
1994 return unknown;
1995 }
1996
1997
1998 /* inquire_formatted()-- Given a fortran string, determine if the file
1999 is suitable for formatted form. Returns a C-style string. */
2000
2001 const char *
2002 inquire_formatted (const char *string, gfc_charlen_type len)
2003 {
2004 struct stat statbuf;
2005
2006 if (string == NULL)
2007 return unknown;
2008
2009 char *path = fc_strdup (string, len);
2010 int err;
2011 TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
2012 free (path);
2013 if (err == -1)
2014 return unknown;
2015
2016 if (S_ISREG (statbuf.st_mode) ||
2017 S_ISBLK (statbuf.st_mode) ||
2018 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
2019 return unknown;
2020
2021 if (S_ISDIR (statbuf.st_mode))
2022 return no;
2023
2024 return unknown;
2025 }
2026
2027
2028 /* inquire_unformatted()-- Given a fortran string, determine if the file
2029 is suitable for unformatted form. Returns a C-style string. */
2030
2031 const char *
2032 inquire_unformatted (const char *string, gfc_charlen_type len)
2033 {
2034 return inquire_formatted (string, len);
2035 }
2036
2037
2038 /* inquire_access()-- Given a fortran string, determine if the file is
2039 suitable for access. */
2040
2041 static const char *
2042 inquire_access (const char *string, gfc_charlen_type len, int mode)
2043 {
2044 if (string == NULL)
2045 return no;
2046 char *path = fc_strdup (string, len);
2047 int res = access (path, mode);
2048 free (path);
2049 if (res == -1)
2050 return no;
2051
2052 return yes;
2053 }
2054
2055
2056 /* inquire_read()-- Given a fortran string, determine if the file is
2057 suitable for READ access. */
2058
2059 const char *
2060 inquire_read (const char *string, gfc_charlen_type len)
2061 {
2062 return inquire_access (string, len, R_OK);
2063 }
2064
2065
2066 /* inquire_write()-- Given a fortran string, determine if the file is
2067 suitable for READ access. */
2068
2069 const char *
2070 inquire_write (const char *string, gfc_charlen_type len)
2071 {
2072 return inquire_access (string, len, W_OK);
2073 }
2074
2075
2076 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2077 suitable for read and write access. */
2078
2079 const char *
2080 inquire_readwrite (const char *string, gfc_charlen_type len)
2081 {
2082 return inquire_access (string, len, R_OK | W_OK);
2083 }
2084
2085
2086 int
2087 stream_isatty (stream *s)
2088 {
2089 return isatty (((unix_stream *) s)->fd);
2090 }
2091
2092 int
2093 stream_ttyname (stream *s __attribute__ ((unused)),
2094 char *buf __attribute__ ((unused)),
2095 size_t buflen __attribute__ ((unused)))
2096 {
2097 #ifdef HAVE_TTYNAME_R
2098 return ttyname_r (((unix_stream *)s)->fd, buf, buflen);
2099 #elif defined HAVE_TTYNAME
2100 char *p;
2101 size_t plen;
2102 p = ttyname (((unix_stream *)s)->fd);
2103 if (!p)
2104 return errno;
2105 plen = strlen (p);
2106 if (buflen < plen)
2107 plen = buflen;
2108 memcpy (buf, p, plen);
2109 return 0;
2110 #else
2111 return ENOSYS;
2112 #endif
2113 }
2114
2115
2116
2117
2118 /* How files are stored: This is an operating-system specific issue,
2119 and therefore belongs here. There are three cases to consider.
2120
2121 Direct Access:
2122 Records are written as block of bytes corresponding to the record
2123 length of the file. This goes for both formatted and unformatted
2124 records. Positioning is done explicitly for each data transfer,
2125 so positioning is not much of an issue.
2126
2127 Sequential Formatted:
2128 Records are separated by newline characters. The newline character
2129 is prohibited from appearing in a string. If it does, this will be
2130 messed up on the next read. End of file is also the end of a record.
2131
2132 Sequential Unformatted:
2133 In this case, we are merely copying bytes to and from main storage,
2134 yet we need to keep track of varying record lengths. We adopt
2135 the solution used by f2c. Each record contains a pair of length
2136 markers:
2137
2138 Length of record n in bytes
2139 Data of record n
2140 Length of record n in bytes
2141
2142 Length of record n+1 in bytes
2143 Data of record n+1
2144 Length of record n+1 in bytes
2145
2146 The length is stored at the end of a record to allow backspacing to the
2147 previous record. Between data transfer statements, the file pointer
2148 is left pointing to the first length of the current record.
2149
2150 ENDFILE records are never explicitly stored.
2151
2152 */