1/* Copyright (C) 2002-2020 Free Software Foundation, Inc. 2 Contributed by Andy Vaught 3 4This file is part of the GNU Fortran 95 runtime library (libgfortran). 5 6Libgfortran is free software; you can redistribute it and/or modify 7it under the terms of the GNU General Public License as published by 8the Free Software Foundation; either version 3, or (at your option) 9any later version. 10 11Libgfortran is distributed in the hope that it will be useful, 12but WITHOUT ANY WARRANTY; without even the implied warranty of 13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14GNU General Public License for more details. 15 16Under Section 7 of GPL version 3, you are granted additional 17permissions described in the GCC Runtime Library Exception, version 183.1, as published by the Free Software Foundation. 19 20You should have received a copy of the GNU General Public License and 21a copy of the GCC Runtime Library Exception along with this program; 22see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 23<http://www.gnu.org/licenses/>. */ 24 25#include "io.h" 26#include "unix.h" 27#include "async.h" 28#include <limits.h> 29#if !HAVE_UNLINK_OPEN_FILE 30#include <string.h> 31#endif 32 33typedef enum 34{ CLOSE_INVALID = - 1, CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED } 35close_status; 36 37static const st_option status_opt[] = { 38 {"keep", CLOSE_KEEP}, 39 {"delete", CLOSE_DELETE}, 40 {NULL, 0} 41}; 42 43 44extern void st_close (st_parameter_close *); 45export_proto(st_close); 46 47void 48st_close (st_parameter_close *clp) 49{ 50 close_status status; 51 gfc_unit *u; 52#if !HAVE_UNLINK_OPEN_FILE 53 char *path; 54 55 path = NULL; 56#endif 57 58 library_start (&clp->common); 59 60 status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED : 61 find_option (&clp->common, clp->status, clp->status_len, 62 status_opt, "Bad STATUS parameter in CLOSE statement"); 63 64 if (status == CLOSE_INVALID) 65 { 66 library_end (); 67 return; 68 } 69 70 u = find_unit (clp->common.unit); 71 72 if (ASYNC_IO && u && u->au) 73 if (async_wait (&(clp->common), u->au)) 74 { 75 library_end (); 76 return; 77 } 78 79 if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK) 80 { 81 library_end (); 82 return; 83 } 84 85 if (u != NULL) 86 { 87 if (close_share (u) < 0) 88 generate_error (&clp->common, LIBERROR_OS, "Problem in CLOSE"); 89 if (u->flags.status == STATUS_SCRATCH) 90 { 91 if (status == CLOSE_KEEP) 92 generate_error (&clp->common, LIBERROR_BAD_OPTION, 93 "Can't KEEP a scratch file on CLOSE"); 94#if !HAVE_UNLINK_OPEN_FILE 95 path = strdup (u->filename); 96#endif 97 } 98 else 99 { 100 if (status == CLOSE_DELETE) 101 { 102 if (u->flags.readonly) 103 generate_warning (&clp->common, "STATUS set to DELETE on CLOSE" 104 " but file protected by READONLY specifier"); 105 else 106 { 107#if HAVE_UNLINK_OPEN_FILE 108 109 if (remove (u->filename)) 110 generate_error (&clp->common, LIBERROR_OS, 111 "File cannot be deleted"); 112#else 113 path = strdup (u->filename); 114#endif 115 } 116 } 117 } 118 119 close_unit (u); 120 121#if !HAVE_UNLINK_OPEN_FILE 122 if (path != NULL) 123 { 124 if (remove (path)) 125 generate_error (&clp->common, LIBERROR_OS, 126 "File cannot be deleted"); 127 free (path); 128 } 129#endif 130 } 131 132 /* CLOSE on unconnected unit is legal and a no-op: F95 std., 9.3.5. */ 133 library_end (); 134} 135