libgfortran/io/unix.c

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