1  /* Copyright (C) 2002-2023 Free Software Foundation, Inc.
       2     Contributed by Andy Vaught
       3  
       4  This file is part of the GNU Fortran 95 runtime library (libgfortran).
       5  
       6  Libgfortran is free software; you can redistribute it and/or modify
       7  it under the terms of the GNU General Public License as published by
       8  the Free Software Foundation; either version 3, or (at your option)
       9  any later version.
      10  
      11  Libgfortran is distributed in the hope that it will be useful,
      12  but WITHOUT ANY WARRANTY; without even the implied warranty of
      13  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      14  GNU General Public License for more details.
      15  
      16  Under Section 7 of GPL version 3, you are granted additional
      17  permissions described in the GCC Runtime Library Exception, version
      18  3.1, as published by the Free Software Foundation.
      19  
      20  You should have received a copy of the GNU General Public License and
      21  a copy of the GCC Runtime Library Exception along with this program;
      22  see 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  
      33  typedef enum
      34  { CLOSE_INVALID = - 1, CLOSE_DELETE, CLOSE_KEEP, CLOSE_UNSPECIFIED }
      35  close_status;
      36  
      37  static const st_option status_opt[] = {
      38    {"keep", CLOSE_KEEP},
      39    {"delete", CLOSE_DELETE},
      40    {NULL, 0}
      41  };
      42  
      43  
      44  extern void st_close (st_parameter_close *);
      45  export_proto(st_close);
      46  
      47  void
      48  st_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  }