home *** CD-ROM | disk | FTP | other *** search
- ------------------------------------------------------------------------------
- -- --
- -- GNAT RUNTIME COMPONENTS --
- -- --
- -- A D A . D I R E C T _ I O --
- -- --
- -- B o d y --
- -- --
- -- $Revision: 1.5 $ --
- -- --
- -- Copyright (c) 1992,1993,1994 NYU, All Rights Reserved --
- -- --
- -- The GNAT library is free software; you can redistribute it and/or modify --
- -- it under terms of the GNU Library General Public License as published by --
- -- the Free Software Foundation; either version 2, or (at your option) any --
- -- later version. The GNAT library is distributed in the hope that it will --
- -- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty --
- -- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
- -- Library General Public License for more details. You should have --
- -- received a copy of the GNU Library General Public License along with --
- -- the GNAT library; see the file COPYING.LIB. If not, write to the Free --
- -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
- -- --
- ------------------------------------------------------------------------------
-
- with Ada.Storage_IO;
- with Interfaces.C; use Interfaces.C;
- with Interfaces.C.Strings; use Interfaces.C.Strings;
- with System.File_Aux; use System.File_Aux;
-
- package body Ada.Direct_IO is
-
- package Stor_IO is new Ada.Storage_IO (Element_Type => Element_Type);
-
- type Pstring is access String;
-
- type File_Control_Block is record
- Name : chars_ptr := Null_Ptr;
- Mode : File_Mode;
- Form : Pstring;
- Descriptor : C_File_Ptr;
- Index : Positive_Count;
- Size : Count;
- end record;
-
- type Open_Type is (Create, Open);
-
- type C_Mode_Type is array (Open_Type, File_Mode) of chars_ptr;
-
- C_Mode : C_Mode_Type := (others => (others => Null_Ptr));
-
- Buffer : Stor_IO.Buffer_Type;
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function To_Element_Index (Index : in C_Long_Int) return Positive_Count;
- pragma Inline (To_Element_Index);
- -- Converts from the zero-based byte index which is used by the C file
- -- positioning functions to the one-based element index which is used
- -- by the Ada.Direct_IO routines.
-
- function To_Byte_Index (Index : in Positive_Count) return C_Long_Int;
- pragma Inline (To_Byte_Index);
- -- Converts from the one-based element index which is used by the
- -- Ada.Direct_IO routines to the zero-based byte index which is used
- -- by the C file positioning functions.
-
- procedure Confirm_File_Is_Open (File : in File_Type);
- pragma Inline (Confirm_File_Is_Open);
- -- Checks to make sure the given file is open.
- -- If not, it raises Status_Error.
-
- procedure Confirm_File_Is_Closed (File : in File_Type);
- pragma Inline (Confirm_File_Is_Closed);
- -- Checks to make sure the given file is closed.
- -- If not, it raises Status_Error.
-
- function New_Temp_File_Name return chars_ptr;
- -- Returns a name that is a valid file name and that is not the same as
- -- the name of an existing external file.
-
- function Current_Size_Of (File : in File_Type) return Count;
- -- Returns the current size in elements of the external file that is
- -- associated with the given file. The given file must be open.
-
- -----------
- -- Close --
- -----------
-
- procedure Close (File : in out File_Type) is
- begin
- Confirm_File_Is_Open (File);
-
- if C_Fclose (File.Descriptor) /= 0 then
- raise Device_Error;
- end if;
-
- File := null;
- end Close;
-
- --------------------------
- -- Confirm_File_Is_Open --
- --------------------------
-
- procedure Confirm_File_Is_Open (File : in File_Type) is
- begin
- if not Is_Open (File) then
- raise Status_Error;
- end if;
- end Confirm_File_Is_Open;
-
- ----------------------------
- -- Confirm_File_Is_Closed --
- ----------------------------
-
- procedure Confirm_File_Is_Closed (File : in File_Type) is
- begin
- if Is_Open (File) then
- raise Status_Error;
- end if;
- end Confirm_File_Is_Closed;
-
- ------------
- -- Create --
- ------------
-
- procedure Create
- (File : in out File_Type;
- Mode : in File_Mode := Inout_File;
- Name : in String := "";
- Form : in String := "")
- is
- begin
- Confirm_File_Is_Closed (File);
- File := new File_Control_Block;
-
- -- A null string for Name specifies creation of a temporary file.
-
- if Name'Length = 0 then
- File.Name := New_Temp_File_Name;
- else
- File.Name := New_String (Name);
- end if;
-
- File.Descriptor := C_Fopen (Filename => File.Name,
- Mode => C_Mode (Create, Mode));
-
- -- If the C fopen call fails, it returns a null pointer.
-
- if C_Void_Ptr (File.Descriptor) = C_Null then
- raise Name_Error;
- end if;
-
- File.Mode := Mode;
- File.Form := new String'(Form);
-
- -- The size of the external file is needed to implement the Size
- -- function and the End_Of_File function. The size of the external
- -- file can be found by performing an fseek to the end of the external
- -- file, querying the file position, and then performing another fseek
- -- back to the original position. This is very portable and reasonably
- -- efficient if done only once. However, it would be too clumsy to
- -- perform two fseeks every time Size or End_Of_File is called.
- -- Instead, Current_Size_Of (which actually performs the fseeks) is
- -- called only once at the time of the opening of the file. The size
- -- of the external file is then stored in the file control block. The
- -- Write procedure is the only procedure that can change the size of
- -- the external file, and it contains code to adjust the size stored
- -- in the file control block if the size of the external file increases.
-
- File.Size := Current_Size_Of (File);
- File.Index := 1;
- end Create;
-
- ---------------------
- -- Current_Size_Of --
- ---------------------
-
- function Current_Size_Of (File : in File_Type) return Count is
- Current_Byte_Index : C_Long_Int;
- Current_Byte_Size : C_Long_Int;
-
- begin
- Current_Byte_Index := C_Ftell (File.Descriptor);
-
- if C_Fseek (Stream => File.Descriptor,
- Offset => 0,
- Whence => C_Seek_End) /= 0 then
- raise Device_Error;
- end if;
-
- Current_Byte_Size := C_Ftell (File.Descriptor);
-
- if C_Fseek (Stream => File.Descriptor,
- Offset => Current_Byte_Index,
- Whence => C_Seek_Set) /= 0 then
- raise Device_Error;
- end if;
-
- return To_Element_Index (Current_Byte_Size) - 1;
- end Current_Size_Of;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete (File : in out File_Type) is
- File_Name_To_Delete : chars_ptr;
-
- begin
- Confirm_File_Is_Open (File);
-
- -- The file should be closed before calling the C remove function.
- -- If the file is open, the behavior of the remove function is
- -- implementation-defined. Closing the file, however, means we
- -- lose the info in the file control block, so we have to save the
- -- file name temporarily in order to have it for use with the remove
- -- function.
-
- File_Name_To_Delete := File.Name;
- Close (File);
-
- if C_Remove (File_Name_To_Delete) /= 0 then
- raise Use_Error;
- end if;
- end Delete;
-
- ----------
- -- Form --
- ----------
-
- function Form (File : in File_Type) return String is
- begin
- Confirm_File_Is_Open (File);
- return File.Form.all;
- end Form;
-
- -----------
- -- Index --
- -----------
-
- function Index (File : in File_Type) return Positive_Count is
- begin
- Confirm_File_Is_Open (File);
- return File.Index;
- end Index;
-
- -------------
- -- Is_Open --
- -------------
-
- function Is_Open (File : in File_Type) return Boolean is
- begin
- return File /= null;
- end Is_Open;
-
- ----------
- -- Mode --
- ----------
-
- function Mode (File : in File_Type) return File_Mode is
- begin
- Confirm_File_Is_Open (File);
- return File.Mode;
- end Mode;
-
- ----------
- -- Name --
- ----------
-
- function Name (File : in File_Type) return String is
- begin
- Confirm_File_Is_Open (File);
- return Value (File.Name);
- end Name;
-
- ------------------------
- -- New_Temp_File_Name --
- ------------------------
-
- function New_Temp_File_Name return chars_ptr is
- Temp_File_Name : String := "ADATMPXX";
- C_Temp_File_Name : chars_ptr;
-
- begin
- C_Temp_File_Name := New_String (Temp_File_Name);
- C_Temp_File_Name := C_Mktemp (C_Temp_File_Name);
- return C_Temp_File_Name;
- end New_Temp_File_Name;
-
- ----------
- -- Open --
- ----------
-
- procedure Open
- (File : in out File_Type;
- Mode : in File_Mode;
- Name : in String;
- Form : in String := "")
- is
- begin
- Confirm_File_Is_Closed (File);
- File := new File_Control_Block;
-
- File.Name := New_String (Name);
- File.Descriptor := C_Fopen (Filename => File.Name,
- Mode => C_Mode (Open, Mode));
-
- -- If the C fopen call fails, it returns a null pointer.
-
- if C_Void_Ptr (File.Descriptor) = C_Null then
- raise Name_Error;
- end if;
-
- File.Mode := Mode;
- File.Form := new String'(Form);
-
- -- The size of the external file is needed to implement the Size
- -- function and the End_Of_File function. The size of the external
- -- file can be found by performing an fseek to the end of the external
- -- file, querying the file position, and then performing another fseek
- -- back to the original position. This is very portable and reasonably
- -- efficient if done only once. However, it would be too clumsy to
- -- perform two fseeks every time Size or End_Of_File is called.
- -- Instead, Current_Size_Of (which actually performs the fseeks) is
- -- called only once at the time of the opening of the file. The size
- -- of the external file is then stored in the file control block. The
- -- Write procedure is the only procedure that can change the size of
- -- the external file, and it contains code to adjust the size stored
- -- in the file control block if the size of the external file increases.
-
- File.Size := Current_Size_Of (File);
- File.Index := 1;
- end Open;
-
- ----------
- -- Read --
- ----------
-
- procedure Read
- (File : in File_Type;
- Item : out Element_Type;
- From : in Positive_Count)
- is
- begin
- Confirm_File_Is_Open (File);
- Set_Index (File, From);
- Read (File, Item);
- end Read;
-
- procedure Read (File : in File_Type; Item : out Element_Type) is
- begin
- Confirm_File_Is_Open (File);
-
- if File.Mode = Out_File then
- raise Mode_Error;
- end if;
-
- if End_Of_File (File) then
- raise End_Error;
- end if;
-
- -- Peforming an fseek here forces the current index stored in the
- -- file control block to match the file position indicator used by
- -- the C file IO functions. They might not match due to a previous
- -- call to Set_Index. Additionally, this takes care of the buffering
- -- problem associated with update mode files. Such files may not mix
- -- reads and writes without an intervening call to fflush or to a
- -- file positioning function (fseek, fsetpos, or rewind).
-
- if C_Fseek (Stream => File.Descriptor,
- Offset => To_Byte_Index (File.Index),
- Whence => C_Seek_Set) /= 0
- then
- raise Device_Error;
- end if;
-
- -- The C fread function returns the number of elements successfully
- -- read. Since we only read one element at a time and we have already
- -- checked for end of file, if the number of elements successfully read
- -- does not equal the number of elements requested, it is considered to
- -- be a Device_Error.
-
- if C_Fread (Ptr => C_Void_Ptr (Buffer'Address),
- Size => C_Size_T (Buffer'Length),
- Nmemb => 1,
- Stream => File.Descriptor) /= 1
- then
- raise Device_Error;
- end if;
-
- Stor_IO.Read (Buffer, Item);
- File.Index := File.Index + 1;
- end Read;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset (File : in out File_Type; Mode : in File_Mode) is
- Old_File : File_Type := File;
-
- begin
- Confirm_File_Is_Open (File);
- Close (File);
- Open (File, Mode, Value (Old_File.Name), Old_File.Form.all);
- end Reset;
-
- procedure Reset (File : in out File_Type) is
- begin
- Confirm_File_Is_Open (File);
- Reset (File, File.Mode);
- end Reset;
-
- ---------------
- -- Set_Index --
- ---------------
-
- procedure Set_Index (File : in File_Type; To : in Positive_Count) is
- begin
- Confirm_File_Is_Open (File);
-
- -- It is not an error to set the current index of the given file to
- -- a value which exceeds the current size of the file.
-
- File.Index := To;
- end Set_Index;
-
- ----------
- -- Size --
- ----------
-
- function Size (File : in File_Type) return Count is
- begin
- Confirm_File_Is_Open (File);
- return File.Size;
- end Size;
-
- ----------------------
- -- To_Element_Index --
- ----------------------
-
- function To_Element_Index (Index : in C_Long_Int) return Positive_Count is
- begin
- return Positive_Count ((Index / Buffer'Length) + 1);
- end To_Element_Index;
-
- -------------------
- -- To_Byte_Index --
- -------------------
-
- function To_Byte_Index (Index : in Positive_Count) return C_Long_Int is
- begin
- return C_Long_Int ((Count (Index) - 1) * Buffer'Length);
- end To_Byte_Index;
-
- -----------
- -- Write --
- -----------
-
- procedure Write
- (File : in File_Type;
- Item : in Element_Type;
- To : in Positive_Count)
- is
- begin
- Confirm_File_Is_Open (File);
- Set_Index (File, To);
- Write (File, Item);
- end Write;
-
- procedure Write (File : in File_Type; Item : in Element_Type) is
- begin
- Confirm_File_Is_Open (File);
-
- if File.Mode = In_File then
- raise Mode_Error;
- end if;
-
- Stor_IO.Write (Buffer, Item);
-
- -- Peforming an fseek here forces the current index stored in the
- -- file control block to match the file position indicator used by
- -- the C file IO functions. They might not match due to a previous
- -- call to Set_Index. Additionally, this takes care of the buffering
- -- problem associated with update mode files. Such files may not mix
- -- reads and writes without an intervening call to fflush or to a
- -- file positioning function (fseek, fsetpos, or rewind).
-
- if C_Fseek (Stream => File.Descriptor,
- Offset => To_Byte_Index (File.Index),
- Whence => C_Seek_Set) /= 0
- then
- raise Device_Error;
- end if;
-
- -- The C fwrite function returns the number of elements successfully
- -- written, which will less than the number of elements requested only
- -- if a write error is encountered. Such a situation is considered to
- -- be a Device_Error.
-
- if C_Fwrite (Ptr => C_Void_Ptr (Buffer'Address),
- Size => C_Size_T (Buffer'Length),
- Nmemb => 1,
- Stream => File.Descriptor) /= 1
- then
- raise Device_Error;
- end if;
-
- -- If the size of the file has increased, store the new size in the
- -- file control block.
-
- if File.Index > File.Size then
- File.Size := File.Index;
- end if;
- File.Index := File.Index + 1;
- end Write;
-
- -----------------
- -- End_Of_File --
- -----------------
-
- function End_Of_File (File : in File_Type) return Boolean is
- begin
- Confirm_File_Is_Open (File);
-
- if File.Mode = Out_File then
- raise Mode_Error;
- end if;
-
- return Index (File) > Size (File);
- end End_Of_File;
-
- begin
- -------------------------
- -- Package Elaboration --
- -------------------------
-
- -- The following possible modes for the C fopen function are given here
- -- for reference:
-
- -- r open text file for reading
- -- w truncate to zero length or create text file for writing
- -- a append; open or create text file for writing at end-of-file
- -- r open file for reading
- -- w truncate to zero length or create file for writing
- -- a append; open or create file for writing at end-of-file
- -- r+ open text file for update (reading and writing)
- -- w+ truncate to zero length or create text file for update
- -- a+ append; open or create text file for update, writing at end-of-file
- -- r+ open file for update (reading and writing)
- -- w+ truncate to zero length or create file for update
- -- a+ append; open or create file for update, writing at end-of-file
-
- -- Notes:
-
- -- (1) Opening a file with read mode fails if the file does not exist or
- -- cannot be read.
-
- -- (2) Opening a file with append mode causes all subsequent writes to the
- -- file to be forced to the then current end-of-file, regardless of
- -- intervening calls to the fseek function.
-
- -- (3) When a file is opened with update mode, both input and output may be
- -- performed on the associated stream. However, output may not be directly
- -- followed by input without an intervening call to the fflush function or
- -- to a file positioning function (fseek, fsetpos, or rewind), and input
- -- may not be directly followed by output without an intervening call to a
- -- file positioning function, unless the input operation encounters
- -- end-of-file.
-
- C_Mode (Create, In_File) := New_String ("w+");
- C_Mode (Create, Out_File) := New_String ("w+");
- C_Mode (Create, Inout_File) := New_String ("w+");
-
- C_Mode (Open, In_File) := New_String ("r+");
- C_Mode (Open, Out_File) := New_String ("r+");
- C_Mode (Open, Inout_File) := New_String ("r+");
- end Ada.Direct_IO;
-