| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUN-TIME COMPONENTS -- |
| -- -- |
| -- S Y S T E M . F I L E _ I O -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2021, 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; |
| pragma Unreferenced (V2); |
| |
| 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; |
