with Ada.Finalization; use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.CRTL;
with System.Soft_Links;
with Unchecked_Deallocation;
package body System.File_IO is
use System.File_Control_Block;
package SSL renames System.Soft_Links;
use type System.CRTL.size_t;
Open_Files : AFCB_Ptr;
type Temp_File_Record;
type Temp_File_Record_Ptr is access all Temp_File_Record;
type Temp_File_Record is record
Name : String (1 .. max_path_len + 1);
Next : Temp_File_Record_Ptr;
end record;
Temp_Files : Temp_File_Record_Ptr;
type File_IO_Clean_Up_Type is new Controlled with null record;
procedure Finalize (V : in out File_IO_Clean_Up_Type);
File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
pragma Warnings (Off, File_IO_Clean_Up_Object);
text_translation_required : Boolean;
pragma Import
(C, text_translation_required, "__gnat_text_translation_required");
procedure Free_String is new Unchecked_Deallocation (String, Pstring);
subtype Fopen_String is String (1 .. 4);
procedure Fopen_Mode
(Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
Fopstr : out Fopen_String);
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;
end if;
end if;
end Append_Set;
procedure Chain_File (File : AFCB_Ptr) is
begin
SSL.Lock_Task.all;
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;
procedure Check_File_Open (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error;
end if;
end Check_File_Open;
procedure Check_Read_Status (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error;
elsif File.Mode > Inout_File then
raise Mode_Error;
end if;
end Check_Read_Status;
procedure Check_Write_Status (File : AFCB_Ptr) is
begin
if File = null then
raise Status_Error;
elsif File.Mode = In_File then
raise Mode_Error;
end if;
end Check_Write_Status;
procedure Close (File : in out AFCB_Ptr) is
Close_Status : int := 0;
Dup_Strm : Boolean := False;
begin
Check_File_Open (File);
AFCB_Close (File);
SSL.Lock_Task.all;
if not File.Is_System_File
and then File.Stream /= NULL_Stream
then
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;
if not Dup_Strm then
Close_Status := fclose (File.Stream);
end if;
end if;
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 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;
end if;
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end Close;
procedure Delete (File : in out AFCB_Ptr) is
begin
Check_File_Open (File);
if not File.Is_Regular_File then
raise Use_Error;
end if;
declare
Filename : aliased constant String := File.Name.all;
begin
Close (File);
if unlink (Filename'Address) = -1 then
raise Use_Error;
end if;
end;
end Delete;
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;
procedure Finalize (V : in out File_IO_Clean_Up_Type) is
pragma Warnings (Off, V);
Fptr1 : AFCB_Ptr;
Fptr2 : AFCB_Ptr;
Discard : int;
pragma Unreferenced (Discard);
begin
SSL.Lock_Task.all;
Fptr1 := Open_Files;
while Fptr1 /= null loop
Fptr2 := Fptr1.Next;
Close (Fptr1);
Fptr1 := Fptr2;
end loop;
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;
procedure Flush (File : AFCB_Ptr) is
begin
Check_Write_Status (File);
if fflush (File.Stream) = 0 then
return;
else
raise Device_Error;
end if;
end Flush;
procedure Fopen_Mode
(Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
Fopstr : out Fopen_String)
is
Fptr : Positive;
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 = 'D' and not Creat then
Fopstr (1) := 'r';
Fopstr (2) := '+';
Fptr := 3;
else
Fopstr (1) := 'w';
Fptr := 2;
end if;
when Inout_File | Append_File =>
if Creat then
Fopstr (1) := 'w';
else
Fopstr (1) := 'r';
end if;
Fopstr (2) := '+';
Fptr := 3;
end case;
if text_translation_required then
if Text then
Fopstr (Fptr) := 't';
else
Fopstr (Fptr) := 'b';
end if;
Fptr := Fptr + 1;
end if;
Fopstr (Fptr) := ASCII.NUL;
end Fopen_Mode;
function Form (File : AFCB_Ptr) return String is
begin
if File = null then
raise Status_Error;
else
return File.Form.all (1 .. File.Form'Length - 1);
end if;
end Form;
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;
end if;
end Form_Boolean;
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;
else
V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
end if;
if V > 999_999 then
raise Use_Error;
end if;
end loop;
return V;
end if;
end Form_Integer;
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;
function Is_Open (File : AFCB_Ptr) return Boolean is
begin
return (File /= null);
end Is_Open;
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;
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);
end Make_Line_Buffered;
procedure Make_Unbuffered (File : AFCB_Ptr) is
status : Integer;
pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IONBF, 0);
end Make_Unbuffered;
function Mode (File : AFCB_Ptr) return File_Mode is
begin
if File = null then
raise Status_Error;
else
return File.Mode;
end if;
end Mode;
function Name (File : AFCB_Ptr) return String is
begin
if File = null then
raise Status_Error;
else
return File.Name.all (1 .. File.Name'Length - 1);
end if;
end Name;
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);
procedure Tmp_Name (Buffer : Address);
pragma Import (C, Tmp_Name, "__gnat_tmp_name");
Stream : FILEs := C_Stream;
Shared : Shared_Status_Type;
Fopstr : aliased Fopen_String;
Formstr : aliased String (1 .. Form'Length + 1);
Tempfile : constant Boolean := (Name'Length = 0);
Namelen : constant Integer := max_path_len;
Namestr : aliased String (1 .. Namelen + 1);
Fullname : aliased String (1 .. max_path_len + 1);
Full_Name_Len : Integer;
begin
if File_Ptr /= null then
raise Status_Error;
end if;
Formstr (1 .. Form'Length) := Form;
Formstr (Formstr'Last) := ASCII.NUL;
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;
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;
end if;
end;
if Stream /= NULL_Stream then
Full_Name_Len := Name'Length + 1;
Fullname (1 .. Full_Name_Len - 1) := Name;
Fullname (Full_Name_Len) := ASCII.Nul;
else
if Tempfile then
if not Creat then
raise Name_Error;
end if;
Tmp_Name (Namestr'Address);
if Namestr (1) = ASCII.NUL then
raise Use_Error;
end if;
begin
SSL.Lock_Task.all;
Temp_Files :=
new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
SSL.Unlock_Task.all;
exception
when others =>
SSL.Unlock_Task.all;
raise;
end;
else
if Name'Length > Namelen then
raise Name_Error;
end if;
Namestr (1 .. Name'Length) := Name;
Namestr (Name'Length + 1) := ASCII.NUL;
end if;
full_name (Namestr'Address, Fullname'Address);
if Fullname (1) = ASCII.NUL then
raise Use_Error;
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;
if Shared /= No then
declare
P : AFCB_Ptr;
begin
SSL.Lock_Task.all;
P := Open_Files;
while P /= null loop
if Fullname (1 .. Full_Name_Len) = P.Name.all then
if Shared = None
or else P.Shared_Status = None
then
raise Use_Error;
elsif Shared = Yes
and then P.Shared_Status = Yes
then
Stream := P.Stream;
exit;
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;
if Stream = NULL_Stream then
Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
if Creat = False and then Fopstr (1) /= 'r' then
if file_exists (Namestr'Address) = 0 then
raise Name_Error;
end if;
end if;
Stream := fopen (Namestr'Address, Fopstr'Address);
if Stream = NULL_Stream then
if file_exists (Namestr'Address) = 0 then
raise Name_Error;
else
raise Use_Error;
end if;
end if;
end if;
end if;
File_Ptr := AFCB_Allocate (Dummy_FCB);
File_Ptr.Is_Regular_File := (is_regular_file
(fileno (Stream)) /= 0);
File_Ptr.Is_System_File := False;
File_Ptr.Is_Text_File := Text;
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;
Chain_File (File_Ptr);
Append_Set (File_Ptr);
end Open;
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;
elsif Nread = 0 then
raise End_Error;
else raise Data_Error;
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;
end if;
end Read_Buf;
procedure Reset (File : in out AFCB_Ptr) is
begin
Check_File_Open (File);
Reset (File, File.Mode);
end Reset;
procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is
Fopstr : aliased Fopen_String;
begin
Check_File_Open (File);
if File.Shared_Status = Yes
or else File.Name'Length <= 1
or else File.Is_System_File
or else (not File.Is_Regular_File)
then
raise Use_Error;
elsif Mode = File.Mode
and then Mode <= Inout_File
then
rewind (File.Stream);
else
Fopen_Mode
(Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
File.Stream :=
freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
if File.Stream = NULL_Stream then
Close (File);
raise Use_Error;
else
File.Mode := Mode;
Append_Set (File);
end if;
end if;
end Reset;
procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
begin
SSL.Abort_Defer.all;
if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
if Siz /= 0 then
SSL.Abort_Undefer.all;
raise Device_Error;
end if;
end if;
SSL.Abort_Undefer.all;
end Write_Buf;
end System.File_IO;