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