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