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