1 /* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
3 Free Software Foundation, Inc.
4 Contributed by Andy Vaught
5 F2003 I/O support contributed by Jerry DeLisle
7 This file is part of the GNU Fortran runtime library (libgfortran).
9 Libgfortran is free software; you can redistribute it and/or modify
10 it under the terms of the GNU General Public License as published by
11 the Free Software Foundation; either version 3, or (at your option)
14 Libgfortran is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 GNU General Public License for more details.
19 Under Section 7 of GPL version 3, you are granted additional
20 permissions described in the GCC Runtime Library Exception, version
21 3.1, as published by the Free Software Foundation.
23 You should have received a copy of the GNU General Public License and
24 a copy of the GCC Runtime Library Exception along with this program;
25 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
26 <http://www.gnu.org/licenses/>. */
28 /* Unix stream I/O module */
44 /* For mingw, we don't identify files by their inode number, but by a
45 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
48 #define WIN32_LEAN_AND_MEAN
51 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
53 #define lseek _lseeki64
55 #define fstat _fstati64
60 #ifndef HAVE_WORKING_STAT
62 id_from_handle (HANDLE hFile)
64 BY_HANDLE_FILE_INFORMATION FileInformation;
66 if (hFile == INVALID_HANDLE_VALUE)
69 memset (&FileInformation, 0, sizeof(FileInformation));
70 if (!GetFileInformationByHandle (hFile, &FileInformation))
73 return ((uint64_t) FileInformation.nFileIndexLow)
74 | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
79 id_from_path (const char *path)
84 if (!path || !*path || access (path, F_OK))
87 hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
88 FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
90 res = id_from_handle (hFile);
97 id_from_fd (const int fd)
99 return id_from_handle ((HANDLE) _get_osfhandle (fd));
106 #define PATH_MAX 1024
109 /* These flags aren't defined on all targets (mingw32), so provide them
142 /* Fallback implementation of access() on systems that don't have it.
143 Only modes R_OK, W_OK and F_OK are used in this file. */
146 fallback_access (const char *path, int mode)
150 if ((mode & R_OK) && (fd = open (path, O_RDONLY)) < 0)
154 if ((mode & W_OK) && (fd = open (path, O_WRONLY)) < 0)
161 return stat (path, &st);
168 #define access fallback_access
172 /* Unix and internal stream I/O module */
174 static const int BUFFER_SIZE = 8192;
180 gfc_offset buffer_offset; /* File offset of the start of the buffer */
181 gfc_offset physical_offset; /* Current physical file offset */
182 gfc_offset logical_offset; /* Current logical file offset */
183 gfc_offset file_length; /* Length of the file, -1 if not seekable. */
185 char *buffer; /* Pointer to the buffer. */
186 int fd; /* The POSIX file descriptor. */
188 int active; /* Length of valid bytes in the buffer */
190 int ndirty; /* Dirty bytes starting at buffer_offset */
192 int special_file; /* =1 if the fd refers to a special file */
194 /* Cached stat(2) values. */
201 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
202 * standard descriptors, returning a non-standard descriptor. If the
203 * user specifies that system errors should go to standard output,
204 * then closes standard output, we don't want the system errors to a
205 * file that has been given file descriptor 1 or 0. We want to send
206 * the error to the invalid descriptor. */
212 int input, output, error;
214 input = output = error = 0;
216 /* Unix allocates the lowest descriptors first, so a loop is not
217 required, but this order is. */
218 if (fd == STDIN_FILENO)
223 if (fd == STDOUT_FILENO)
228 if (fd == STDERR_FILENO)
235 close (STDIN_FILENO);
237 close (STDOUT_FILENO);
239 close (STDERR_FILENO);
246 /* If the stream corresponds to a preconnected unit, we flush the
247 corresponding C stream. This is bugware for mixed C-Fortran codes
248 where the C code doesn't flush I/O before returning. */
250 flush_if_preconnected (stream * s)
254 fd = ((unix_stream *) s)->fd;
255 if (fd == STDIN_FILENO)
257 else if (fd == STDOUT_FILENO)
259 else if (fd == STDERR_FILENO)
264 /********************************************************************
265 Raw I/O functions (read, write, seek, tell, truncate, close).
267 These functions wrap the basic POSIX I/O syscalls. Any deviation in
268 semantics is a bug, except the following: write restarts in case
269 of being interrupted by a signal, and as the first argument the
270 functions take the unix_stream struct rather than an integer file
271 descriptor. Also, for POSIX read() and write() a nbyte argument larger
272 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
273 than size_t as for POSIX read/write.
274 *********************************************************************/
277 raw_flush (unix_stream * s __attribute__ ((unused)))
283 raw_read (unix_stream * s, void * buf, ssize_t nbyte)
285 /* For read we can't do I/O in a loop like raw_write does, because
286 that will break applications that wait for interactive I/O. */
287 return read (s->fd, buf, nbyte);
291 raw_write (unix_stream * s, const void * buf, ssize_t nbyte)
293 ssize_t trans, bytes_left;
297 buf_st = (char *) buf;
299 /* We must write in a loop since some systems don't restart system
300 calls in case of a signal. */
301 while (bytes_left > 0)
303 trans = write (s->fd, buf_st, bytes_left);
315 return nbyte - bytes_left;
319 raw_seek (unix_stream * s, gfc_offset offset, int whence)
321 return lseek (s->fd, offset, whence);
325 raw_tell (unix_stream * s)
327 return lseek (s->fd, 0, SEEK_CUR);
331 raw_truncate (unix_stream * s, gfc_offset length)
342 h = (HANDLE) _get_osfhandle (s->fd);
343 if (h == INVALID_HANDLE_VALUE)
348 cur = lseek (s->fd, 0, SEEK_CUR);
351 if (lseek (s->fd, length, SEEK_SET) == -1)
353 if (!SetEndOfFile (h))
358 if (lseek (s->fd, cur, SEEK_SET) == -1)
362 lseek (s->fd, cur, SEEK_SET);
364 #elif defined HAVE_FTRUNCATE
365 return ftruncate (s->fd, length);
366 #elif defined HAVE_CHSIZE
367 return chsize (s->fd, length);
369 runtime_error ("required ftruncate or chsize support not present");
375 raw_close (unix_stream * s)
379 if (s->fd != STDOUT_FILENO
380 && s->fd != STDERR_FILENO
381 && s->fd != STDIN_FILENO)
382 retval = close (s->fd);
390 raw_init (unix_stream * s)
392 s->st.read = (void *) raw_read;
393 s->st.write = (void *) raw_write;
394 s->st.seek = (void *) raw_seek;
395 s->st.tell = (void *) raw_tell;
396 s->st.trunc = (void *) raw_truncate;
397 s->st.close = (void *) raw_close;
398 s->st.flush = (void *) raw_flush;
405 /*********************************************************************
406 Buffered I/O functions. These functions have the same semantics as the
407 raw I/O functions above, except that they are buffered in order to
408 improve performance. The buffer must be flushed when switching from
409 reading to writing and vice versa.
410 *********************************************************************/
413 buf_flush (unix_stream * s)
417 /* Flushing in read mode means discarding read bytes. */
423 if (s->file_length != -1 && s->physical_offset != s->buffer_offset
424 && lseek (s->fd, s->buffer_offset, SEEK_SET) < 0)
427 writelen = raw_write (s, s->buffer, s->ndirty);
429 s->physical_offset = s->buffer_offset + writelen;
431 /* Don't increment file_length if the file is non-seekable. */
432 if (s->file_length != -1 && s->physical_offset > s->file_length)
433 s->file_length = s->physical_offset;
435 s->ndirty -= writelen;
447 buf_read (unix_stream * s, void * buf, ssize_t nbyte)
450 s->buffer_offset = s->logical_offset;
452 /* Is the data we want in the buffer? */
453 if (s->logical_offset + nbyte <= s->buffer_offset + s->active
454 && s->buffer_offset <= s->logical_offset)
455 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset), nbyte);
458 /* First copy the active bytes if applicable, then read the rest
459 either directly or filling the buffer. */
462 ssize_t to_read, did_read;
463 gfc_offset new_logical;
466 if (s->logical_offset >= s->buffer_offset
467 && s->buffer_offset + s->active >= s->logical_offset)
469 nread = s->active - (s->logical_offset - s->buffer_offset);
470 memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
474 /* At this point we consider all bytes in the buffer discarded. */
475 to_read = nbyte - nread;
476 new_logical = s->logical_offset + nread;
477 if (s->file_length != -1 && s->physical_offset != new_logical
478 && lseek (s->fd, new_logical, SEEK_SET) < 0)
480 s->buffer_offset = s->physical_offset = new_logical;
481 if (to_read <= BUFFER_SIZE/2)
483 did_read = raw_read (s, s->buffer, BUFFER_SIZE);
484 s->physical_offset += did_read;
485 s->active = did_read;
486 did_read = (did_read > to_read) ? to_read : did_read;
487 memcpy (p, s->buffer, did_read);
491 did_read = raw_read (s, p, to_read);
492 s->physical_offset += did_read;
495 nbyte = did_read + nread;
497 s->logical_offset += nbyte;
502 buf_write (unix_stream * s, const void * buf, ssize_t nbyte)
505 s->buffer_offset = s->logical_offset;
507 /* Does the data fit into the buffer? As a special case, if the
508 buffer is empty and the request is bigger than BUFFER_SIZE/2,
509 write directly. This avoids the case where the buffer would have
510 to be flushed at every write. */
511 if (!(s->ndirty == 0 && nbyte > BUFFER_SIZE/2)
512 && s->logical_offset + nbyte <= s->buffer_offset + BUFFER_SIZE
513 && s->buffer_offset <= s->logical_offset
514 && s->buffer_offset + s->ndirty >= s->logical_offset)
516 memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
517 int nd = (s->logical_offset - s->buffer_offset) + nbyte;
523 /* Flush, and either fill the buffer with the new data, or if
524 the request is bigger than the buffer size, write directly
525 bypassing the buffer. */
527 if (nbyte <= BUFFER_SIZE/2)
529 memcpy (s->buffer, buf, nbyte);
530 s->buffer_offset = s->logical_offset;
535 if (s->file_length != -1 && s->physical_offset != s->logical_offset)
537 if (lseek (s->fd, s->logical_offset, SEEK_SET) < 0)
539 s->physical_offset = s->logical_offset;
542 nbyte = raw_write (s, buf, nbyte);
543 s->physical_offset += nbyte;
546 s->logical_offset += nbyte;
547 /* Don't increment file_length if the file is non-seekable. */
548 if (s->file_length != -1 && s->logical_offset > s->file_length)
549 s->file_length = s->logical_offset;
554 buf_seek (unix_stream * s, gfc_offset offset, int whence)
561 offset += s->logical_offset;
564 offset += s->file_length;
574 s->logical_offset = offset;
579 buf_tell (unix_stream * s)
581 return s->logical_offset;
585 buf_truncate (unix_stream * s, gfc_offset length)
589 if (buf_flush (s) != 0)
591 r = raw_truncate (s, length);
593 s->file_length = length;
598 buf_close (unix_stream * s)
600 if (buf_flush (s) != 0)
603 return raw_close (s);
607 buf_init (unix_stream * s)
609 s->st.read = (void *) buf_read;
610 s->st.write = (void *) buf_write;
611 s->st.seek = (void *) buf_seek;
612 s->st.tell = (void *) buf_tell;
613 s->st.trunc = (void *) buf_truncate;
614 s->st.close = (void *) buf_close;
615 s->st.flush = (void *) buf_flush;
617 s->buffer = get_mem (BUFFER_SIZE);
622 /*********************************************************************
623 memory stream functions - These are used for internal files
625 The idea here is that a single stream structure is created and all
626 requests must be satisfied from it. The location and size of the
627 buffer is the character variable supplied to the READ or WRITE
630 *********************************************************************/
633 mem_alloc_r (stream * strm, int * len)
635 unix_stream * s = (unix_stream *) strm;
637 gfc_offset where = s->logical_offset;
639 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
642 n = s->buffer_offset + s->active - where;
646 s->logical_offset = where + *len;
648 return s->buffer + (where - s->buffer_offset);
653 mem_alloc_r4 (stream * strm, int * len)
655 unix_stream * s = (unix_stream *) strm;
657 gfc_offset where = s->logical_offset;
659 if (where < s->buffer_offset || where > s->buffer_offset + s->active)
662 n = s->buffer_offset + s->active - where;
666 s->logical_offset = where + *len;
668 return s->buffer + (where - s->buffer_offset) * 4;
673 mem_alloc_w (stream * strm, int * len)
675 unix_stream * s = (unix_stream *) strm;
677 gfc_offset where = s->logical_offset;
681 if (where < s->buffer_offset)
684 if (m > s->file_length)
687 s->logical_offset = m;
689 return s->buffer + (where - s->buffer_offset);
694 mem_alloc_w4 (stream * strm, int * len)
696 unix_stream * s = (unix_stream *) strm;
698 gfc_offset where = s->logical_offset;
699 gfc_char4_t *result = (gfc_char4_t *) s->buffer;
703 if (where < s->buffer_offset)
706 if (m > s->file_length)
709 s->logical_offset = m;
710 return &result[where - s->buffer_offset];
714 /* Stream read function for character(kine=1) internal units. */
717 mem_read (stream * s, void * buf, ssize_t nbytes)
722 p = mem_alloc_r (s, &nb);
733 /* Stream read function for chracter(kind=4) internal units. */
736 mem_read4 (stream * s, void * buf, ssize_t nbytes)
741 p = mem_alloc_r (s, &nb);
752 /* Stream write function for character(kind=1) internal units. */
755 mem_write (stream * s, const void * buf, ssize_t nbytes)
760 p = mem_alloc_w (s, &nb);
771 /* Stream write function for character(kind=4) internal units. */
774 mem_write4 (stream * s, const void * buf, ssize_t nwords)
779 p = mem_alloc_w4 (s, &nw);
783 *p++ = (gfc_char4_t) *((char *) buf);
792 mem_seek (stream * strm, gfc_offset offset, int whence)
794 unix_stream * s = (unix_stream *) strm;
800 offset += s->logical_offset;
803 offset += s->file_length;
809 /* Note that for internal array I/O it's actually possible to have a
810 negative offset, so don't check for that. */
811 if (offset > s->file_length)
817 s->logical_offset = offset;
819 /* Returning < 0 is the error indicator for sseek(), so return 0 if
820 offset is negative. Thus if the return value is 0, the caller
821 has to use stell() to get the real value of logical_offset. */
829 mem_tell (stream * s)
831 return ((unix_stream *)s)->logical_offset;
836 mem_truncate (unix_stream * s __attribute__ ((unused)),
837 gfc_offset length __attribute__ ((unused)))
844 mem_flush (unix_stream * s __attribute__ ((unused)))
851 mem_close (unix_stream * s)
859 /*********************************************************************
860 Public functions -- A reimplementation of this module needs to
861 define functional equivalents of the following.
862 *********************************************************************/
864 /* open_internal()-- Returns a stream structure from a character(kind=1)
868 open_internal (char *base, int length, gfc_offset offset)
872 s = get_mem (sizeof (unix_stream));
873 memset (s, '\0', sizeof (unix_stream));
876 s->buffer_offset = offset;
878 s->logical_offset = 0;
879 s->active = s->file_length = length;
881 s->st.close = (void *) mem_close;
882 s->st.seek = (void *) mem_seek;
883 s->st.tell = (void *) mem_tell;
884 s->st.trunc = (void *) mem_truncate;
885 s->st.read = (void *) mem_read;
886 s->st.write = (void *) mem_write;
887 s->st.flush = (void *) mem_flush;
892 /* open_internal4()-- Returns a stream structure from a character(kind=4)
896 open_internal4 (char *base, int length, gfc_offset offset)
900 s = get_mem (sizeof (unix_stream));
901 memset (s, '\0', sizeof (unix_stream));
904 s->buffer_offset = offset;
906 s->logical_offset = 0;
907 s->active = s->file_length = length;
909 s->st.close = (void *) mem_close;
910 s->st.seek = (void *) mem_seek;
911 s->st.tell = (void *) mem_tell;
912 s->st.trunc = (void *) mem_truncate;
913 s->st.read = (void *) mem_read4;
914 s->st.write = (void *) mem_write4;
915 s->st.flush = (void *) mem_flush;
921 /* fd_to_stream()-- Given an open file descriptor, build a stream
925 fd_to_stream (int fd)
930 s = get_mem (sizeof (unix_stream));
931 memset (s, '\0', sizeof (unix_stream));
934 s->buffer_offset = 0;
935 s->physical_offset = 0;
936 s->logical_offset = 0;
938 /* Get the current length of the file. */
940 fstat (fd, &statbuf);
942 s->st_dev = statbuf.st_dev;
943 s->st_ino = statbuf.st_ino;
944 s->special_file = !S_ISREG (statbuf.st_mode);
946 if (S_ISREG (statbuf.st_mode))
947 s->file_length = statbuf.st_size;
948 else if (S_ISBLK (statbuf.st_mode))
950 /* Hopefully more portable than ioctl(fd, BLKGETSIZE64, &size)? */
951 gfc_offset cur = lseek (fd, 0, SEEK_CUR);
952 s->file_length = lseek (fd, 0, SEEK_END);
953 lseek (fd, cur, SEEK_SET);
958 if (!(S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
959 || options.all_unbuffered
960 ||(options.unbuffered_preconnected &&
961 (s->fd == STDIN_FILENO
962 || s->fd == STDOUT_FILENO
963 || s->fd == STDERR_FILENO))
973 /* Given the Fortran unit number, convert it to a C file descriptor. */
976 unit_to_fd (int unit)
981 us = find_unit (unit);
985 fd = ((unix_stream *) us->s)->fd;
991 /* unpack_filename()-- Given a fortran string and a pointer to a
992 * buffer that is PATH_MAX characters, convert the fortran string to a
993 * C string in the buffer. Returns nonzero if this is not possible. */
996 unpack_filename (char *cstring, const char *fstring, int len)
1000 len = fstrlen (fstring, len);
1001 if (len >= PATH_MAX)
1004 memmove (cstring, fstring, len);
1005 cstring[len] = '\0';
1011 /* tempfile()-- Generate a temporary filename for a scratch file and
1012 * open it. mkstemp() opens the file for reading and writing, but the
1013 * library mode prevents anything that is not allowed. The descriptor
1014 * is returned, which is -1 on error. The template is pointed to by
1015 * opp->file, which is copied into the unit structure
1016 * and freed later. */
1019 tempfile (st_parameter_open *opp)
1021 const char *tempdir;
1023 const char *slash = "/";
1027 #ifndef HAVE_MKSTEMP
1032 tempdir = getenv ("GFORTRAN_TMPDIR");
1034 if (tempdir == NULL)
1036 char buffer[MAX_PATH + 1];
1038 ret = GetTempPath (MAX_PATH, buffer);
1039 /* If we are not able to get a temp-directory, we use
1040 current directory. */
1041 if (ret > MAX_PATH || !ret)
1045 tempdir = strdup (buffer);
1048 if (tempdir == NULL)
1049 tempdir = getenv ("TMP");
1050 if (tempdir == NULL)
1051 tempdir = getenv ("TEMP");
1052 if (tempdir == NULL)
1053 tempdir = DEFAULT_TEMPDIR;
1056 /* Check for special case that tempdir contains slash
1057 or backslash at end. */
1058 tempdirlen = strlen (tempdir);
1059 if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1061 || tempdir[tempdirlen - 1] == '\\'
1066 // Take care that the template is longer in the mktemp() branch.
1067 template = get_mem (tempdirlen + 23);
1070 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1073 fd = mkstemp (template);
1075 #else /* HAVE_MKSTEMP */
1078 slashlen = strlen (slash);
1081 snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1086 template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1088 template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1090 template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1095 if (!mktemp (template))
1102 #if defined(HAVE_CRLF) && defined(O_BINARY)
1103 fd = open (template, O_RDWR | O_CREAT | O_EXCL | O_BINARY,
1104 S_IREAD | S_IWRITE);
1106 fd = open (template, O_RDWR | O_CREAT | O_EXCL, S_IREAD | S_IWRITE);
1109 while (fd == -1 && errno == EEXIST);
1110 #endif /* HAVE_MKSTEMP */
1112 opp->file = template;
1113 opp->file_len = strlen (template); /* Don't include trailing nul */
1119 /* regular_file()-- Open a regular file.
1120 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1121 * unless an error occurs.
1122 * Returns the descriptor, which is less than zero on error. */
1125 regular_file (st_parameter_open *opp, unit_flags *flags)
1127 char path[PATH_MAX + 1];
1133 if (unpack_filename (path, opp->file, opp->file_len))
1135 errno = ENOENT; /* Fake an OS error */
1140 if (opp->file_len == 7)
1142 if (strncmp (path, "CONOUT$", 7) == 0
1143 || strncmp (path, "CONERR$", 7) == 0)
1145 fd = open ("/dev/conout", O_WRONLY);
1146 flags->action = ACTION_WRITE;
1151 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1153 fd = open ("/dev/conin", O_RDONLY);
1154 flags->action = ACTION_READ;
1161 if (opp->file_len == 7)
1163 if (strncmp (path, "CONOUT$", 7) == 0
1164 || strncmp (path, "CONERR$", 7) == 0)
1166 fd = open ("CONOUT$", O_WRONLY);
1167 flags->action = ACTION_WRITE;
1172 if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1174 fd = open ("CONIN$", O_RDONLY);
1175 flags->action = ACTION_READ;
1182 switch (flags->action)
1192 case ACTION_READWRITE:
1193 case ACTION_UNSPECIFIED:
1198 internal_error (&opp->common, "regular_file(): Bad action");
1201 switch (flags->status)
1204 crflag = O_CREAT | O_EXCL;
1207 case STATUS_OLD: /* open will fail if the file does not exist*/
1211 case STATUS_UNKNOWN:
1212 case STATUS_SCRATCH:
1216 case STATUS_REPLACE:
1217 crflag = O_CREAT | O_TRUNC;
1221 internal_error (&opp->common, "regular_file(): Bad status");
1224 /* rwflag |= O_LARGEFILE; */
1226 #if defined(HAVE_CRLF) && defined(O_BINARY)
1230 mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1231 fd = open (path, rwflag | crflag, mode);
1232 if (flags->action != ACTION_UNSPECIFIED)
1237 flags->action = ACTION_READWRITE;
1240 if (errno != EACCES && errno != EROFS)
1243 /* retry for read-only access */
1245 fd = open (path, rwflag | crflag, mode);
1248 flags->action = ACTION_READ;
1249 return fd; /* success */
1252 if (errno != EACCES)
1253 return fd; /* failure */
1255 /* retry for write-only access */
1257 fd = open (path, rwflag | crflag, mode);
1260 flags->action = ACTION_WRITE;
1261 return fd; /* success */
1263 return fd; /* failure */
1267 /* open_external()-- Open an external file, unix specific version.
1268 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1269 * Returns NULL on operating system error. */
1272 open_external (st_parameter_open *opp, unit_flags *flags)
1276 if (flags->status == STATUS_SCRATCH)
1278 fd = tempfile (opp);
1279 if (flags->action == ACTION_UNSPECIFIED)
1280 flags->action = ACTION_READWRITE;
1282 #if HAVE_UNLINK_OPEN_FILE
1283 /* We can unlink scratch files now and it will go away when closed. */
1290 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1292 fd = regular_file (opp, flags);
1299 return fd_to_stream (fd);
1303 /* input_stream()-- Return a stream pointer to the default input stream.
1304 * Called on initialization. */
1309 return fd_to_stream (STDIN_FILENO);
1313 /* output_stream()-- Return a stream pointer to the default output stream.
1314 * Called on initialization. */
1317 output_stream (void)
1321 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1322 setmode (STDOUT_FILENO, O_BINARY);
1325 s = fd_to_stream (STDOUT_FILENO);
1330 /* error_stream()-- Return a stream pointer to the default error stream.
1331 * Called on initialization. */
1338 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1339 setmode (STDERR_FILENO, O_BINARY);
1342 s = fd_to_stream (STDERR_FILENO);
1347 /* st_vprintf()-- vprintf function for error output. To avoid buffer
1348 overruns, we limit the length of the buffer to ST_VPRINTF_SIZE. 2k
1349 is big enough to completely fill a 80x25 terminal, so it shuld be
1350 OK. We use a direct write() because it is simpler and least likely
1351 to be clobbered by memory corruption. Writing an error message
1352 longer than that is an error. */
1354 #define ST_VPRINTF_SIZE 2048
1357 st_vprintf (const char *format, va_list ap)
1359 static char buffer[ST_VPRINTF_SIZE];
1363 fd = options.use_stderr ? STDERR_FILENO : STDOUT_FILENO;
1364 #ifdef HAVE_VSNPRINTF
1365 written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
1367 written = vsprintf(buffer, format, ap);
1369 if (written >= ST_VPRINTF_SIZE-1)
1371 /* The error message was longer than our buffer. Ouch. Because
1372 we may have messed up things badly, report the error and
1374 #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
1375 write (fd, buffer, ST_VPRINTF_SIZE-1);
1376 write (fd, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
1378 #undef ERROR_MESSAGE
1383 written = write (fd, buffer, written);
1387 /* st_printf()-- printf() function for error output. This just calls
1388 st_vprintf() to do the actual work. */
1391 st_printf (const char *format, ...)
1395 va_start (ap, format);
1396 written = st_vprintf(format, ap);
1402 /* compare_file_filename()-- Given an open stream and a fortran string
1403 * that is a filename, figure out if the file is the same as the
1407 compare_file_filename (gfc_unit *u, const char *name, int len)
1409 char path[PATH_MAX + 1];
1411 #ifdef HAVE_WORKING_STAT
1419 if (unpack_filename (path, name, len))
1420 return 0; /* Can't be the same */
1422 /* If the filename doesn't exist, then there is no match with the
1425 if (stat (path, &st) < 0)
1428 #ifdef HAVE_WORKING_STAT
1429 s = (unix_stream *) (u->s);
1430 return (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1434 /* We try to match files by a unique ID. On some filesystems (network
1435 fs and FAT), we can't generate this unique ID, and will simply compare
1437 id1 = id_from_path (path);
1438 id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1440 return (id1 == id2);
1443 if (len != u->file_len)
1445 return (memcmp(path, u->file, len) == 0);
1450 #ifdef HAVE_WORKING_STAT
1451 # define FIND_FILE0_DECL struct stat *st
1452 # define FIND_FILE0_ARGS st
1454 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1455 # define FIND_FILE0_ARGS id, file, file_len
1458 /* find_file0()-- Recursive work function for find_file() */
1461 find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1464 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1471 #ifdef HAVE_WORKING_STAT
1474 unix_stream *s = (unix_stream *) (u->s);
1475 if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1480 if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1487 if (compare_string (u->file_len, u->file, file_len, file) == 0)
1491 v = find_file0 (u->left, FIND_FILE0_ARGS);
1495 v = find_file0 (u->right, FIND_FILE0_ARGS);
1503 /* find_file()-- Take the current filename and see if there is a unit
1504 * that has the file already open. Returns a pointer to the unit if so. */
1507 find_file (const char *file, gfc_charlen_type file_len)
1509 char path[PATH_MAX + 1];
1512 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1516 if (unpack_filename (path, file, file_len))
1519 if (stat (path, &st[0]) < 0)
1522 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1523 id = id_from_path (path);
1526 __gthread_mutex_lock (&unit_lock);
1528 u = find_file0 (unit_root, FIND_FILE0_ARGS);
1532 if (! __gthread_mutex_trylock (&u->lock))
1534 /* assert (u->closed == 0); */
1535 __gthread_mutex_unlock (&unit_lock);
1539 inc_waiting_locked (u);
1541 __gthread_mutex_unlock (&unit_lock);
1544 __gthread_mutex_lock (&u->lock);
1547 __gthread_mutex_lock (&unit_lock);
1548 __gthread_mutex_unlock (&u->lock);
1549 if (predec_waiting_locked (u) == 0)
1554 dec_waiting_unlocked (u);
1560 flush_all_units_1 (gfc_unit *u, int min_unit)
1564 if (u->unit_number > min_unit)
1566 gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1570 if (u->unit_number >= min_unit)
1572 if (__gthread_mutex_trylock (&u->lock))
1576 __gthread_mutex_unlock (&u->lock);
1584 flush_all_units (void)
1589 __gthread_mutex_lock (&unit_lock);
1592 u = flush_all_units_1 (unit_root, min_unit);
1594 inc_waiting_locked (u);
1595 __gthread_mutex_unlock (&unit_lock);
1599 __gthread_mutex_lock (&u->lock);
1601 min_unit = u->unit_number + 1;
1606 __gthread_mutex_lock (&unit_lock);
1607 __gthread_mutex_unlock (&u->lock);
1608 (void) predec_waiting_locked (u);
1612 __gthread_mutex_lock (&unit_lock);
1613 __gthread_mutex_unlock (&u->lock);
1614 if (predec_waiting_locked (u) == 0)
1622 /* delete_file()-- Given a unit structure, delete the file associated
1623 * with the unit. Returns nonzero if something went wrong. */
1626 delete_file (gfc_unit * u)
1628 char path[PATH_MAX + 1];
1630 if (unpack_filename (path, u->file, u->file_len))
1631 { /* Shouldn't be possible */
1636 return unlink (path);
1640 /* file_exists()-- Returns nonzero if the current filename exists on
1644 file_exists (const char *file, gfc_charlen_type file_len)
1646 char path[PATH_MAX + 1];
1648 if (unpack_filename (path, file, file_len))
1651 return !(access (path, F_OK));
1655 /* file_size()-- Returns the size of the file. */
1658 file_size (const char *file, gfc_charlen_type file_len)
1660 char path[PATH_MAX + 1];
1661 struct stat statbuf;
1663 if (unpack_filename (path, file, file_len))
1666 if (stat (path, &statbuf) < 0)
1669 return (GFC_IO_INT) statbuf.st_size;
1672 static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1674 /* inquire_sequential()-- Given a fortran string, determine if the
1675 * file is suitable for sequential access. Returns a C-style
1679 inquire_sequential (const char *string, int len)
1681 char path[PATH_MAX + 1];
1682 struct stat statbuf;
1684 if (string == NULL ||
1685 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1688 if (S_ISREG (statbuf.st_mode) ||
1689 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1692 if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1699 /* inquire_direct()-- Given a fortran string, determine if the file is
1700 * suitable for direct access. Returns a C-style string. */
1703 inquire_direct (const char *string, int len)
1705 char path[PATH_MAX + 1];
1706 struct stat statbuf;
1708 if (string == NULL ||
1709 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1712 if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1715 if (S_ISDIR (statbuf.st_mode) ||
1716 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1723 /* inquire_formatted()-- Given a fortran string, determine if the file
1724 * is suitable for formatted form. Returns a C-style string. */
1727 inquire_formatted (const char *string, int len)
1729 char path[PATH_MAX + 1];
1730 struct stat statbuf;
1732 if (string == NULL ||
1733 unpack_filename (path, string, len) || stat (path, &statbuf) < 0)
1736 if (S_ISREG (statbuf.st_mode) ||
1737 S_ISBLK (statbuf.st_mode) ||
1738 S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1741 if (S_ISDIR (statbuf.st_mode))
1748 /* inquire_unformatted()-- Given a fortran string, determine if the file
1749 * is suitable for unformatted form. Returns a C-style string. */
1752 inquire_unformatted (const char *string, int len)
1754 return inquire_formatted (string, len);
1758 /* inquire_access()-- Given a fortran string, determine if the file is
1759 * suitable for access. */
1762 inquire_access (const char *string, int len, int mode)
1764 char path[PATH_MAX + 1];
1766 if (string == NULL || unpack_filename (path, string, len) ||
1767 access (path, mode) < 0)
1774 /* inquire_read()-- Given a fortran string, determine if the file is
1775 * suitable for READ access. */
1778 inquire_read (const char *string, int len)
1780 return inquire_access (string, len, R_OK);
1784 /* inquire_write()-- Given a fortran string, determine if the file is
1785 * suitable for READ access. */
1788 inquire_write (const char *string, int len)
1790 return inquire_access (string, len, W_OK);
1794 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1795 * suitable for read and write access. */
1798 inquire_readwrite (const char *string, int len)
1800 return inquire_access (string, len, R_OK | W_OK);
1804 /* file_length()-- Return the file length in bytes, -1 if unknown */
1807 file_length (stream * s)
1809 gfc_offset curr, end;
1810 if (!is_seekable (s))
1815 end = sseek (s, 0, SEEK_END);
1816 sseek (s, curr, SEEK_SET);
1821 /* is_seekable()-- Return nonzero if the stream is seekable, zero if
1825 is_seekable (stream *s)
1827 /* By convention, if file_length == -1, the file is not
1829 return ((unix_stream *) s)->file_length!=-1;
1833 /* is_special()-- Return nonzero if the stream is not a regular file. */
1836 is_special (stream *s)
1838 return ((unix_stream *) s)->special_file;
1843 stream_isatty (stream *s)
1845 return isatty (((unix_stream *) s)->fd);
1849 stream_ttyname (stream *s __attribute__ ((unused)),
1850 char * buf __attribute__ ((unused)),
1851 size_t buflen __attribute__ ((unused)))
1853 #ifdef HAVE_TTYNAME_R
1854 return ttyname_r (((unix_stream *) s)->fd, buf, buflen);
1855 #elif defined HAVE_TTYNAME
1858 p = ttyname (((unix_stream *) s)->fd);
1864 memcpy (buf, p, plen);
1874 /* How files are stored: This is an operating-system specific issue,
1875 and therefore belongs here. There are three cases to consider.
1878 Records are written as block of bytes corresponding to the record
1879 length of the file. This goes for both formatted and unformatted
1880 records. Positioning is done explicitly for each data transfer,
1881 so positioning is not much of an issue.
1883 Sequential Formatted:
1884 Records are separated by newline characters. The newline character
1885 is prohibited from appearing in a string. If it does, this will be
1886 messed up on the next read. End of file is also the end of a record.
1888 Sequential Unformatted:
1889 In this case, we are merely copying bytes to and from main storage,
1890 yet we need to keep track of varying record lengths. We adopt
1891 the solution used by f2c. Each record contains a pair of length
1894 Length of record n in bytes
1896 Length of record n in bytes
1898 Length of record n+1 in bytes
1900 Length of record n+1 in bytes
1902 The length is stored at the end of a record to allow backspacing to the
1903 previous record. Between data transfer statements, the file pointer
1904 is left pointing to the first length of the current record.
1906 ENDFILE records are never explicitly stored.