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