blob: 3fdb29730a5458207633c4dae2e6e402fe77417c [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . F I L E _ I O --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Finalization; use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.Case_Util; use System.Case_Util;
with System.CRTL;
with System.OS_Lib;
with System.Soft_Links;
package body System.File_IO is
use System.File_Control_Block;
package SSL renames System.Soft_Links;
use type CRTL.size_t;
----------------------
-- Global Variables --
----------------------
Open_Files : AFCB_Ptr;
-- This points to a list of AFCB's for all open files. This is a doubly
-- linked list, with the Prev pointer of the first entry, and the Next
-- pointer of the last entry containing null. Note that this global
-- variable must be properly protected to provide thread safety.
type Temp_File_Record;
type Temp_File_Record_Ptr is access all Temp_File_Record;
type Temp_File_Record is record
File : AFCB_Ptr;
Next : aliased Temp_File_Record_Ptr;
Name : String (1 .. max_path_len + 1);
end record;
-- One of these is allocated for each temporary file created
Temp_Files : aliased Temp_File_Record_Ptr;
-- Points to list of names of temporary files. Note that this global
-- variable must be properly protected to provide thread safety.
procedure Free is new Ada.Unchecked_Deallocation
(Temp_File_Record, Temp_File_Record_Ptr);
type File_IO_Clean_Up_Type is new Limited_Controlled with null record;
-- The closing of all open files and deletion of temporary files is an
-- action that takes place at the end of execution of the main program.
-- This action is implemented using a library level object that gets
-- finalized at the end of program execution. Note that the type is
-- limited, in order to stop the compiler optimizing away the declaration
-- which would be allowed in the non-limited case.
procedure Finalize (V : in out File_IO_Clean_Up_Type);
-- This is the finalize operation that is used to do the cleanup
File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
pragma Warnings (Off, File_IO_Clean_Up_Object);
-- This is the single object of the type that triggers the finalization
-- call. Since it is at the library level, this happens just before the
-- environment task is finalized.
text_translation_required : Boolean;
for text_translation_required'Size use Character'Size;
pragma Import
(C, text_translation_required, "__gnat_text_translation_required");
-- If true, add appropriate suffix to control string for Open
-----------------------
-- Local Subprograms --
-----------------------
procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
subtype Fopen_String is String (1 .. 4);
-- Holds open string (longest is "w+b" & nul)
procedure Fopen_Mode
(Namestr : String;
Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
Fopstr : out Fopen_String);
-- Determines proper open mode for a file to be opened in the given Ada
-- mode. Namestr is the NUL-terminated file name. Text is true for a text
-- file and false otherwise, and Creat is true for a create call, and False
-- for an open call. The value stored in Fopstr is a nul-terminated string
-- suitable for a call to fopen or freopen. Amethod is the character
-- designating the access method from the Access_Method field of the FCB.
function Errno_Message
(Name : String;
Errno : Integer := OS_Lib.Errno) return String;
-- Return Errno_Message for Errno, with file name prepended
procedure Raise_Device_Error
(File : AFCB_Ptr;
Errno : Integer := OS_Lib.Errno);
pragma No_Return (Raise_Device_Error);
-- Clear error indication on File and raise Device_Error with an exception
-- message providing errno information.
----------------
-- Append_Set --
----------------
procedure Append_Set (File : AFCB_Ptr) is
begin
if File.Mode = Append_File then
if fseek (File.Stream, 0, SEEK_END) /= 0 then
Raise_Device_Error (File);
end if;
end if;
end Append_Set;
----------------
-- Chain_File --
----------------
procedure Chain_File (File : AFCB_Ptr) is
begin
-- Take a task lock, to protect the global data value Open_Files
SSL.Lock_Task.all;
-- Do the chaining operation locked
File.Next := Open_Files;
File.Prev := null;
Open_Files := File;
if File.Next /= null then
File.Next.Prev := File;
end if;
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end Chain_File;
---------------------
-- Check_File_Open --
---------------------
procedure Check_File_Open (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error with "file not open";
end if;
end Check_File_Open;
-----------------------
-- Check_Read_Status --
-----------------------
procedure Check_Read_Status (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error with "file not open";
elsif File.Mode not in Read_File_Mode then
raise Mode_Error with "file not readable";
end if;
end Check_Read_Status;
------------------------
-- Check_Write_Status --
------------------------
procedure Check_Write_Status (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error with "file not open";
elsif File.Mode = In_File then
raise Mode_Error with "file not writable";
end if;
end Check_Write_Status;
-----------
-- Close --
-----------
procedure Close (File_Ptr : access AFCB_Ptr) is
Close_Status : int := 0;
Dup_Strm : Boolean := False;
Errno : Integer := 0;
File : AFCB_Ptr renames File_Ptr.all;
begin
-- Take a task lock, to protect the global variables Open_Files and
-- Temp_Files, and the chains they point to.
SSL.Lock_Task.all;
Check_File_Open (File);
AFCB_Close (File);
-- Sever the association between the given file and its associated
-- external file. The given file is left closed. Do not perform system
-- closes on the standard input, output and error files and also do not
-- attempt to close a stream that does not exist (signalled by a null
-- stream value -- happens in some error situations).
if not File.Is_System_File and then File.Stream /= NULL_Stream then
-- Do not do an fclose if this is a shared file and there is at least
-- one other instance of the stream that is open.
if File.Shared_Status = Yes then
declare
P : AFCB_Ptr;
begin
P := Open_Files;
while P /= null loop
if P /= File and then File.Stream = P.Stream then
Dup_Strm := True;
exit;
end if;
P := P.Next;
end loop;
end;
end if;
-- Do the fclose unless this was a duplicate in the shared case
if not Dup_Strm then
Close_Status := fclose (File.Stream);
if Close_Status /= 0 then
Errno := OS_Lib.Errno;
end if;
end if;
end if;
-- Dechain file from list of open files and then free the storage
if File.Prev = null then
Open_Files := File.Next;
else
File.Prev.Next := File.Next;
end if;
if File.Next /= null then
File.Next.Prev := File.Prev;
end if;
-- If it's a temp file, remove the corresponding record from Temp_Files,
-- and delete the file. There are unlikely to be large numbers of temp
-- files open, so a linear search is sufficiently efficient. Note that
-- we don't need to check for end of list, because the file must be
-- somewhere on the list. Note that as for Finalize, we ignore any
-- errors while attempting the unlink operation.
if File.Is_Temporary_File then
declare
Temp : access Temp_File_Record_Ptr := Temp_Files'Access;
-- Note the double indirection here
Discard : int;
New_Temp : Temp_File_Record_Ptr;
begin
while Temp.all.all.File /= File loop
Temp := Temp.all.all.Next'Access;
end loop;
Discard := unlink (Temp.all.all.Name'Address);
New_Temp := Temp.all.all.Next;
Free (Temp.all);
Temp.all := New_Temp;
end;
end if;
-- Deallocate some parts of the file structure that were kept in heap
-- storage with the exception of system files (standard input, output
-- and error) since they had some information allocated in the stack.
if not File.Is_System_File then
Free_String (File.Name);
Free_String (File.Form);
AFCB_Free (File);
end if;
File := null;
if Close_Status /= 0 then
Raise_Device_Error (null, Errno);
end if;
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end Close;
------------
-- Delete --
------------
procedure Delete (File_Ptr : access AFCB_Ptr) is
File : AFCB_Ptr renames File_Ptr.all;
begin
Check_File_Open (File);
if not File.Is_Regular_File then
raise Use_Error with "cannot delete non-regular file";
end if;
declare
Filename : aliased constant String := File.Name.all;
Is_Temporary_File : constant Boolean := File.Is_Temporary_File;
begin
Close (File_Ptr);
-- Now unlink the external file. Note that we use the full name in
-- this unlink, because the working directory may have changed since
-- we did the open, and we want to unlink the right file. However, if
-- it's a temporary file, then closing it already unlinked it.
if not Is_Temporary_File then
if unlink (Filename'Address) = -1 then
raise Use_Error with OS_Lib.Errno_Message;
end if;
end if;
end;
end Delete;
-----------------
-- End_Of_File --
-----------------
function End_Of_File (File : AFCB_Ptr) return Boolean is
begin
Check_File_Open (File);
if feof (File.Stream) /= 0 then
return True;
else
Check_Read_Status (File);
if ungetc (fgetc (File.Stream), File.Stream) = EOF then
clearerr (File.Stream);
return True;
else
return False;
end if;
end if;
end End_Of_File;
-------------------
-- Errno_Message --
-------------------
function Errno_Message
(Name : String;
Errno : Integer := OS_Lib.Errno) return String
is
begin
return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
end Errno_Message;
--------------
-- Finalize --
--------------
procedure Finalize (V : in out File_IO_Clean_Up_Type) is
pragma Warnings (Off, V);
Fptr1 : aliased AFCB_Ptr;
Fptr2 : AFCB_Ptr;
Discard : int;
begin
-- Take a lock to protect global Open_Files data structure
SSL.Lock_Task.all;
-- First close all open files (the slightly complex form of this loop is
-- required because Close nulls out its argument).
Fptr1 := Open_Files;
while Fptr1 /= null loop
Fptr2 := Fptr1.Next;
Close (Fptr1'Access);
Fptr1 := Fptr2;
end loop;
-- Now unlink all temporary files. We do not bother to free the blocks
-- because we are just about to terminate the program. We also ignore
-- any errors while attempting these unlink operations.
while Temp_Files /= null loop
Discard := unlink (Temp_Files.Name'Address);
Temp_Files := Temp_Files.Next;
end loop;
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end Finalize;
-----------
-- Flush --
-----------
procedure Flush (File : AFCB_Ptr) is
begin
Check_Write_Status (File);
if fflush (File.Stream) /= 0 then
Raise_Device_Error (File);
end if;
end Flush;
----------------
-- Fopen_Mode --
----------------
-- The fopen mode to be used is shown by the following table:
-- OPEN CREATE
-- Append_File "r+" "w+"
-- In_File "r" "w+"
-- Out_File (Direct_IO, Stream_IO) "r+" [*] "w"
-- Out_File (others) "w" "w"
-- Inout_File "r+" "w+"
-- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a
-- named pipe), we use "w" instead of "r+". This is necessary to make a
-- write to the fifo block until a reader is ready.
-- Note: we do not use "a" or "a+" for Append_File, since this would not
-- work in the case of stream files, where even if in append file mode,
-- you can reset to earlier points in the file. The caller must use the
-- Append_Set routine to deal with the necessary positioning.
-- Note: in several cases, the fopen mode used allows reading and writing,
-- but the setting of the Ada mode is more restrictive. For instance,
-- Create in In_File mode uses "w+" which allows writing, but the Ada mode
-- In_File will cause any write operations to be rejected with Mode_Error
-- in any case.
-- Note: for the Out_File/Open cases for other than the Direct_IO case, an
-- initial call will be made by the caller to first open the file in "r"
-- mode to be sure that it exists. The real open, in "w" mode, will then
-- destroy this file. This is peculiar, but that's what Ada semantics
-- require and the ACATS tests insist on.
-- If text file translation is required, then either "b" or "t" is appended
-- to the mode, depending on the setting of Text.
procedure Fopen_Mode
(Namestr : String;
Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
Fopstr : out Fopen_String)
is
Fptr : Positive;
function is_fifo (Path : Address) return Integer;
pragma Import (C, is_fifo, "__gnat_is_fifo");
begin
case Mode is
when In_File =>
if Creat then
Fopstr (1) := 'w';
Fopstr (2) := '+';
Fptr := 3;
else
Fopstr (1) := 'r';
Fptr := 2;
end if;
when Out_File =>
if Amethod in 'D' | 'S'
and then not Creat
and then is_fifo (Namestr'Address) = 0
then
Fopstr (1) := 'r';
Fopstr (2) := '+';
Fptr := 3;
else
Fopstr (1) := 'w';
Fptr := 2;
end if;
when Append_File
| Inout_File
=>
Fopstr (1) := (if Creat then 'w' else 'r');
Fopstr (2) := '+';
Fptr := 3;
end case;
-- If text_translation_required is true then we need to append either a
-- "t" or "b" to the string to get the right mode.
if text_translation_required then
Fopstr (Fptr) := (if Text then 't' else 'b');
Fptr := Fptr + 1;
end if;
Fopstr (Fptr) := ASCII.NUL;
end Fopen_Mode;
----------
-- Form --
----------
function Form (File : AFCB_Ptr) return String is
begin
if File = null then
raise Status_Error with "Form: file not open";
else
return File.Form.all (1 .. File.Form'Length - 1);
end if;
end Form;
------------------
-- Form_Boolean --
------------------
function Form_Boolean
(Form : String;
Keyword : String;
Default : Boolean) return Boolean
is
V1, V2 : Natural;
begin
Form_Parameter (Form, Keyword, V1, V2);
if V1 = 0 then
return Default;
elsif Form (V1) = 'y' then
return True;
elsif Form (V1) = 'n' then
return False;
else
raise Use_Error with "invalid Form";
end if;
end Form_Boolean;
------------------
-- Form_Integer --
------------------
function Form_Integer
(Form : String;
Keyword : String;
Default : Integer) return Integer
is
V1, V2 : Natural;
V : Integer;
begin
Form_Parameter (Form, Keyword, V1, V2);
if V1 = 0 then
return Default;
else
V := 0;
for J in V1 .. V2 loop
if Form (J) not in '0' .. '9' then
raise Use_Error with "invalid Form";
else
V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
end if;
if V > 999_999 then
raise Use_Error with "invalid Form";
end if;
end loop;
return V;
end if;
end Form_Integer;
--------------------
-- Form_Parameter --
--------------------
procedure Form_Parameter
(Form : String;
Keyword : String;
Start : out Natural;
Stop : out Natural)
is
Klen : constant Integer := Keyword'Length;
begin
for J in Form'First + Klen .. Form'Last - 1 loop
if Form (J) = '='
and then Form (J - Klen .. J - 1) = Keyword
then
Start := J + 1;
Stop := Start - 1;
while Form (Stop + 1) /= ASCII.NUL
and then Form (Stop + 1) /= ','
loop
Stop := Stop + 1;
end loop;
return;
end if;
end loop;
Start := 0;
Stop := 0;
end Form_Parameter;
-------------
-- Is_Open --
-------------
function Is_Open (File : AFCB_Ptr) return Boolean is
begin
-- We return True if the file is open, and the underlying file stream is
-- usable. In particular on Windows an application linked with -mwindows
-- option set does not have a console attached. In this case standard
-- files (Current_Output, Current_Error, Current_Input) are not created.
-- We want Is_Open (Current_Output) to return False in this case.
return File /= null and then fileno (File.Stream) /= -1;
end Is_Open;
-------------------
-- Make_Buffered --
-------------------
procedure Make_Buffered
(File : AFCB_Ptr;
Buf_Siz : Interfaces.C_Streams.size_t)
is
status : Integer;
pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
end Make_Buffered;
------------------------
-- Make_Line_Buffered --
------------------------
procedure Make_Line_Buffered
(File : AFCB_Ptr;
Line_Siz : Interfaces.C_Streams.size_t)
is
status : Integer;
pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
-- No error checking???
end Make_Line_Buffered;
---------------------
-- Make_Unbuffered --
---------------------
procedure Make_Unbuffered (File : AFCB_Ptr) is
status : Integer;
pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IONBF, 0);
-- No error checking???
end Make_Unbuffered;
----------
-- Mode --
----------
function Mode (File : AFCB_Ptr) return File_Mode is
begin
if File = null then
raise Status_Error with "Mode: file not open";
else
return File.Mode;
end if;
end Mode;
----------
-- Name --
----------
function Name (File : AFCB_Ptr) return String is
begin
if File = null then
raise Status_Error with "Name: file not open";
else
return File.Name.all (1 .. File.Name'Length - 1);
end if;
end Name;
----------
-- Open --
----------
procedure Open
(File_Ptr : in out AFCB_Ptr;
Dummy_FCB : AFCB'Class;
Mode : File_Mode;
Name : String;
Form : String;
Amethod : Character;
Creat : Boolean;
Text : Boolean;
C_Stream : FILEs := NULL_Stream)
is
pragma Warnings (Off, Dummy_FCB);
-- Yes we know this is never assigned a value. That's intended, since
-- all we ever use of this value is the tag for dispatching purposes.
procedure Tmp_Name (Buffer : Address);
pragma Import (C, Tmp_Name, "__gnat_tmp_name");
-- Set buffer (a String address) with a temporary filename
function Get_Case_Sensitive return Integer;
pragma Import (C, Get_Case_Sensitive,
"__gnat_get_file_names_case_sensitive");
procedure Record_AFCB;
-- Create and record new AFCB into the runtime, note that the
-- implementation uses the variables below which corresponds to the
-- status of the opened file.
File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
-- Set to indicate whether the operating system convention is for file
-- names to be case sensitive (e.g., in Unix, set True), or not case
-- sensitive (e.g., in Windows, set False). Declared locally to avoid
-- breaking the Preelaborate rule that disallows function calls at the
-- library level.
Stream : FILEs := C_Stream;
-- Stream which we open in response to this request
Shared : Shared_Status_Type;
-- Setting of Shared_Status field for file
Fopstr : aliased Fopen_String;
-- Mode string used in fopen call
Formstr : aliased String (1 .. Form'Length + 1);
-- Form string with ASCII.NUL appended, folded to lower case
Text_Encoding : Content_Encoding;
Tempfile : constant Boolean := Name = "" and Stream = NULL_Stream;
-- Indicates temporary file case, which is indicated by an empty file
-- name and no specified Stream.
Namelen : constant Integer := max_path_len;
-- Length required for file name, not including final ASCII.NUL.
-- Note that we used to reference L_tmpnam here, which is not reliable
-- since __gnat_tmp_name does not always use tmpnam.
Namestr : aliased String (1 .. Namelen + 1);
-- Name as given or temporary file name with ASCII.NUL appended
Fullname : aliased String (1 .. max_path_len + 1);
-- Full name (as required for Name function, and as stored in the
-- control block in the Name field) with ASCII.NUL appended.
Full_Name_Len : Integer;
-- Length of name actually stored in Fullname
Encoding : CRTL.Filename_Encoding;
-- Filename encoding specified into the form parameter
-----------------
-- Record_AFCB --
-----------------
procedure Record_AFCB is
begin
File_Ptr := AFCB_Allocate (Dummy_FCB);
-- Note that we cannot use an aggregate here as File_Ptr is a
-- class-wide access to a limited type (Root_Stream_Type).
File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0;
File_Ptr.Is_System_File := False;
File_Ptr.Text_Encoding := Text_Encoding;
File_Ptr.Shared_Status := Shared;
File_Ptr.Access_Method := Amethod;
File_Ptr.Stream := Stream;
File_Ptr.Form := new String'(Formstr);
File_Ptr.Name := new String'(Fullname
(1 .. Full_Name_Len));
File_Ptr.Mode := Mode;
File_Ptr.Is_Temporary_File := Tempfile;
File_Ptr.Encoding := Encoding;
Chain_File (File_Ptr);
Append_Set (File_Ptr);
end Record_AFCB;
-- Start of processing for Open
begin
if File_Ptr /= null then
raise Status_Error with "file already open";
end if;
-- Acquire form string, setting required NUL terminator
Formstr (1 .. Form'Length) := Form;
Formstr (Formstr'Last) := ASCII.NUL;
-- Convert form string to lower case
for J in Formstr'Range loop
if Formstr (J) in 'A' .. 'Z' then
Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
end if;
end loop;
-- Acquire setting of shared parameter
declare
V1, V2 : Natural;
begin
Form_Parameter (Formstr, "shared", V1, V2);
if V1 = 0 then
Shared := None;
elsif Formstr (V1 .. V2) = "yes" then
Shared := Yes;
elsif Formstr (V1 .. V2) = "no" then
Shared := No;
else
raise Use_Error with "invalid Form";
end if;
end;
-- Acquire setting of encoding parameter
declare
V1, V2 : Natural;
begin
Form_Parameter (Formstr, "encoding", V1, V2);
if V1 = 0 then
Encoding := CRTL.Unspecified;
elsif Formstr (V1 .. V2) = "utf8" then
Encoding := CRTL.UTF8;
elsif Formstr (V1 .. V2) = "8bits" then
Encoding := CRTL.ASCII_8bits;
else
raise Use_Error with "invalid Form";
end if;
end;
-- Acquire setting of text_translation parameter. Only needed if this is
-- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
-- if the Form says Text_Translation=No, we use binary mode, so new-line
-- will be just LF, even on Windows.
if Text then
Text_Encoding := Default_Text;
else
Text_Encoding := None;
end if;
if Text_Encoding in Text_Content_Encoding then
declare
V1, V2 : Natural;
begin
Form_Parameter (Formstr, "text_translation", V1, V2);
if V1 = 0 then
null;
elsif Formstr (V1 .. V2) = "no" then
Text_Encoding := None;
elsif Formstr (V1 .. V2) = "text"
or else Formstr (V1 .. V2) = "yes"
then
Text_Encoding := Interfaces.C_Streams.Text;
elsif Formstr (V1 .. V2) = "wtext" then
Text_Encoding := Wtext;
elsif Formstr (V1 .. V2) = "u8text" then
Text_Encoding := U8text;
elsif Formstr (V1 .. V2) = "u16text" then
Text_Encoding := U16text;
else
raise Use_Error with "invalid Form";
end if;
end;
end if;
-- If we were given a stream (call from xxx.C_Streams.Open), then set
-- the full name to the given one, and skip to end of processing.
if Stream /= NULL_Stream then
Full_Name_Len := Name'Length + 1;
Fullname (1 .. Full_Name_Len - 1) := Name;
Fullname (Full_Name_Len) := ASCII.NUL;
-- Normal case of Open or Create
else
-- If temporary file case, get temporary file name and add to the
-- list of temporary files to be deleted on exit.
if Tempfile then
if not Creat then
raise Name_Error with "opening temp file without creating it";
end if;
Tmp_Name (Namestr'Address);
if Namestr (1) = ASCII.NUL then
raise Use_Error with "invalid temp file name";
end if;
-- Normal case of non-empty name given (i.e. not a temp file)
else
if Name'Length > Namelen then
raise Name_Error with "file name too long";
end if;
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
end if;
-- Get full name in accordance with the advice of RM A.8.2(22)
full_name (Namestr'Address, Fullname'Address);
if Fullname (1) = ASCII.NUL then
raise Use_Error with Errno_Message (Name);
end if;
Full_Name_Len := 1;
while Full_Name_Len < Fullname'Last
and then Fullname (Full_Name_Len) /= ASCII.NUL
loop
Full_Name_Len := Full_Name_Len + 1;
end loop;
-- Fullname is generated by calling system's full_name. The problem
-- is, full_name does nothing about the casing, so a file name
-- comparison may generally speaking not be valid on non-case-
-- sensitive systems, and in particular we get unexpected failures
-- on Windows/Vista because of this. So we use s-casuti to force
-- the name to lower case.
if not File_Names_Case_Sensitive then
To_Lower (Fullname (1 .. Full_Name_Len));
end if;
-- If Shared=None or Shared=Yes, then check for the existence of
-- another file with exactly the same full name.
if Shared /= No then
declare
P : AFCB_Ptr;
begin
-- Take a task lock to protect Open_Files
SSL.Lock_Task.all;
-- Search list of open files
P := Open_Files;
while P /= null loop
if Fullname (1 .. Full_Name_Len) = P.Name.all then
-- If we get a match, and either file has Shared=None,
-- then raise Use_Error, since we don't allow two files
-- of the same name to be opened unless they specify the
-- required sharing mode.
if Shared = None
or else P.Shared_Status = None
then
raise Use_Error with "reopening shared file";
-- If both files have Shared=Yes, then we acquire the
-- stream from the located file to use as our stream.
elsif Shared = Yes
and then P.Shared_Status = Yes
then
Stream := P.Stream;
Record_AFCB;
pragma Assert (not Tempfile);
exit;
-- Otherwise one of the files has Shared=Yes and one has
-- Shared=No. If the current file has Shared=No then all
-- is well but we don't want to share any other file's
-- stream. If the current file has Shared=Yes, we would
-- like to share a stream, but not from a file that has
-- Shared=No, so either way, we just continue the search.
else
null;
end if;
end if;
P := P.Next;
end loop;
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end;
end if;
-- Open specified file if we did not find an existing stream,
-- otherwise we just return as there is nothing more to be done.
if Stream /= NULL_Stream then
return;
else
Fopen_Mode
(Namestr => Namestr,
Mode => Mode,
Text => Text_Encoding in Text_Content_Encoding,
Creat => Creat,
Amethod => Amethod,
Fopstr => Fopstr);
-- A special case, if we are opening (OPEN case) a file and the
-- mode returned by Fopen_Mode is not "r" or "r+", then we first
-- make sure that the file exists as required by Ada semantics.
if not Creat and then Fopstr (1) /= 'r' then
if file_exists (Namestr'Address) = 0 then
raise Name_Error with Errno_Message (Name);
end if;
end if;
-- Now open the file. Note that we use the name as given in the
-- original Open call for this purpose, since that seems the
-- clearest implementation of the intent. It would presumably
-- work to use the full name here, but if there is any difference,
-- then we should use the name used in the call.
-- Note: for a corresponding delete, we will use the full name,
-- since by the time of the delete, the current working directory
-- may have changed and we do not want to delete a different file.
Stream :=
fopen (Namestr'Address, Fopstr'Address, Encoding);
if Stream = NULL_Stream then
-- Raise Name_Error if trying to open a non-existent file.
-- Otherwise raise Use_Error.
-- Should we raise Device_Error for ENOSPC???
declare
function Is_File_Not_Found_Error
(Errno_Value : Integer) return Integer;
pragma Import
(C, Is_File_Not_Found_Error,
"__gnat_is_file_not_found_error");
-- Non-zero when the given errno value indicates a non-
-- existing file.
Errno : constant Integer := OS_Lib.Errno;
Message : constant String := Errno_Message (Name, Errno);
begin
if Is_File_Not_Found_Error (Errno) /= 0 then
raise Name_Error with Message;
else
raise Use_Error with Message;
end if;
end;
end if;
end if;
end if;
-- Stream has been successfully located or opened, so now we are
-- committed to completing the opening of the file. Allocate block on
-- heap and fill in its fields.
Record_AFCB;
if Tempfile then
-- Chain to temp file list, ensuring thread safety with a lock
begin
SSL.Lock_Task.all;
Temp_Files :=
new Temp_File_Record'
(File => File_Ptr, Name => Namestr, Next => Temp_Files);
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end;
end if;
end Open;
------------------------
-- Raise_Device_Error --
------------------------
procedure Raise_Device_Error
(File : AFCB_Ptr;
Errno : Integer := OS_Lib.Errno)
is
begin
-- Clear error status so that the same error is not reported twice
if File /= null then
clearerr (File.Stream);
end if;
raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
end Raise_Device_Error;
--------------
-- Read_Buf --
--------------
procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
Nread : size_t;
begin
Nread := fread (Buf, 1, Siz, File.Stream);
if Nread = Siz then
return;
elsif ferror (File.Stream) /= 0 then
Raise_Device_Error (File);
elsif Nread = 0 then
raise End_Error;
else -- 0 < Nread < Siz
raise Data_Error with "not enough data read";
end if;
end Read_Buf;
procedure Read_Buf
(File : AFCB_Ptr;
Buf : Address;
Siz : Interfaces.C_Streams.size_t;
Count : out Interfaces.C_Streams.size_t)
is
begin
Count := fread (Buf, 1, Siz, File.Stream);
if Count = 0 and then ferror (File.Stream) /= 0 then
Raise_Device_Error (File);
end if;
end Read_Buf;
-----------
-- Reset --
-----------
-- The reset which does not change the mode simply does a rewind
procedure Reset (File_Ptr : access AFCB_Ptr) is
File : AFCB_Ptr renames File_Ptr.all;
begin
Check_File_Open (File);
Reset (File_Ptr, File.Mode);
end Reset;
-- The reset with a change in mode is done using freopen, and is not
-- permitted except for regular files (since otherwise there is no name for
-- the freopen, and in any case it seems meaningless).
procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
File : AFCB_Ptr renames File_Ptr.all;
Fopstr : aliased Fopen_String;
begin
Check_File_Open (File);
-- Change of mode not allowed for shared file or file with no name or
-- file that is not a regular file, or for a system file. Note that we
-- allow the "change" of mode if it is not in fact doing a change.
if Mode /= File.Mode then
if File.Shared_Status = Yes then
raise Use_Error with "cannot change mode of shared file";
elsif File.Name'Length <= 1 then
raise Use_Error with "cannot change mode of temp file";
elsif File.Is_System_File then
raise Use_Error with "cannot change mode of system file";
elsif not File.Is_Regular_File then
raise Use_Error with "cannot change mode of non-regular file";
end if;
end if;
-- For In_File or Inout_File for a regular file, we can just do a rewind
-- if the mode is unchanged, which is more efficient than doing a full
-- reopen.
if Mode = File.Mode
and then Mode in Read_File_Mode
then
rewind (File.Stream);
-- Here the change of mode is permitted, we do it by reopening the file
-- in the new mode and replacing the stream with a new stream.
else
Fopen_Mode
(Namestr => File.Name.all,
Mode => Mode,
Text => File.Text_Encoding in Text_Content_Encoding,
Creat => False,
Amethod => File.Access_Method,
Fopstr => Fopstr);
File.Stream := freopen
(File.Name.all'Address, Fopstr'Address, File.Stream,
File.Encoding);
if File.Stream = NULL_Stream then
Close (File_Ptr);
raise Use_Error;
else
File.Mode := Mode;
Append_Set (File);
end if;
end if;
end Reset;
---------------
-- Write_Buf --
---------------
procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
begin
-- Note: for most purposes, the Siz and 1 parameters in the fwrite call
-- could be reversed, but we have encountered systems where this is a
-- better choice, since for some file formats, reversing the parameters
-- results in records of one byte each.
SSL.Abort_Defer.all;
if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
if Siz /= 0 then
SSL.Abort_Undefer.all;
Raise_Device_Error (File);
end if;
end if;
SSL.Abort_Undefer.all;
end Write_Buf;
end System.File_IO;