1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada
.Finalization
; use Ada
.Finalization
;
35 with Ada
.IO_Exceptions
; use Ada
.IO_Exceptions
;
36 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
39 with System
.Case_Util
; use System
.Case_Util
;
40 with System
.Soft_Links
;
42 with Ada
.Unchecked_Deallocation
;
44 package body System
.File_IO
is
46 use System
.File_Control_Block
;
48 package SSL
renames System
.Soft_Links
;
50 use type System
.CRTL
.size_t
;
52 ----------------------
53 -- Global Variables --
54 ----------------------
56 Open_Files
: AFCB_Ptr
;
57 -- This points to a list of AFCB's for all open files. This is a doubly
58 -- linked list, with the Prev pointer of the first entry, and the Next
59 -- pointer of the last entry containing null. Note that this global
60 -- variable must be properly protected to provide thread safety.
62 type Temp_File_Record
;
63 type Temp_File_Record_Ptr
is access all Temp_File_Record
;
65 type Temp_File_Record
is record
66 Name
: String (1 .. max_path_len
+ 1);
67 Next
: Temp_File_Record_Ptr
;
69 -- One of these is allocated for each temporary file created
71 Temp_Files
: Temp_File_Record_Ptr
;
72 -- Points to list of names of temporary files. Note that this global
73 -- variable must be properly protected to provide thread safety.
75 type File_IO_Clean_Up_Type
is new Controlled
with null record;
76 -- The closing of all open files and deletion of temporary files is an
77 -- action which takes place at the end of execution of the main program.
78 -- This action can be implemented using a library level object which
79 -- gets finalized at the end of the main program execution. The above is
80 -- a controlled type introduced for this purpose.
82 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
);
83 -- This is the finalize operation that is used to do the cleanup
85 File_IO_Clean_Up_Object
: File_IO_Clean_Up_Type
;
86 pragma Warnings
(Off
, File_IO_Clean_Up_Object
);
87 -- This is the single object of the type that triggers the finalization
88 -- call. Since it is at the library level, this happens just before the
89 -- environment task is finalized.
91 text_translation_required
: Boolean;
92 for text_translation_required
'Size use Character'Size;
94 (C
, text_translation_required
, "__gnat_text_translation_required");
95 -- If true, add appropriate suffix to control string for Open
97 function Get_Case_Sensitive
return Integer;
98 pragma Import
(C
, Get_Case_Sensitive
,
99 "__gnat_get_file_names_case_sensitive");
100 File_Names_Case_Sensitive
: constant Boolean := Get_Case_Sensitive
/= 0;
101 -- Set to indicate whether the operating system convention is for file
102 -- names to be case sensitive (e.g., in Unix, set True), or non case
103 -- sensitive (e.g., in OS/2, set False).
105 -----------------------
106 -- Local Subprograms --
107 -----------------------
109 procedure Free_String
is new Ada
.Unchecked_Deallocation
(String, Pstring
);
111 subtype Fopen_String
is String (1 .. 4);
112 -- Holds open string (longest is "w+b" & nul)
119 Fopstr
: out Fopen_String
);
120 -- Determines proper open mode for a file to be opened in the given
121 -- Ada mode. Text is true for a text file and false otherwise, and
122 -- Creat is true for a create call, and False for an open call. The
123 -- value stored in Fopstr is a nul-terminated string suitable for a
124 -- call to fopen or freopen. Amethod is the character designating
125 -- the access method from the Access_Method field of the FCB.
131 procedure Append_Set
(File
: AFCB_Ptr
) is
133 if File
.Mode
= Append_File
then
134 if fseek
(File
.Stream
, 0, SEEK_END
) /= 0 then
144 procedure Chain_File
(File
: AFCB_Ptr
) is
146 -- Take a task lock, to protect the global data value Open_Files
150 -- Do the chaining operation locked
152 File
.Next
:= Open_Files
;
156 if File
.Next
/= null then
157 File
.Next
.Prev
:= File
;
168 ---------------------
169 -- Check_File_Open --
170 ---------------------
172 procedure Check_File_Open
(File
: AFCB_Ptr
) is
179 -----------------------
180 -- Check_Read_Status --
181 -----------------------
183 procedure Check_Read_Status
(File
: AFCB_Ptr
) is
187 elsif File
.Mode
> Inout_File
then
190 end Check_Read_Status
;
192 ------------------------
193 -- Check_Write_Status --
194 ------------------------
196 procedure Check_Write_Status
(File
: AFCB_Ptr
) is
200 elsif File
.Mode
= In_File
then
203 end Check_Write_Status
;
209 procedure Close
(File
: in out AFCB_Ptr
) is
210 Close_Status
: int
:= 0;
211 Dup_Strm
: Boolean := False;
214 -- Take a task lock, to protect the global data value Open_Files
218 Check_File_Open
(File
);
221 -- Sever the association between the given file and its associated
222 -- external file. The given file is left closed. Do not perform system
223 -- closes on the standard input, output and error files and also do
224 -- not attempt to close a stream that does not exist (signalled by a
225 -- null stream value -- happens in some error situations).
227 if not File
.Is_System_File
228 and then File
.Stream
/= NULL_Stream
230 -- Do not do an fclose if this is a shared file and there is
231 -- at least one other instance of the stream that is open.
233 if File
.Shared_Status
= Yes
then
241 and then File
.Stream
= P
.Stream
252 -- Do the fclose unless this was a duplicate in the shared case
255 Close_Status
:= fclose
(File
.Stream
);
259 -- Dechain file from list of open files and then free the storage
261 if File
.Prev
= null then
262 Open_Files
:= File
.Next
;
264 File
.Prev
.Next
:= File
.Next
;
267 if File
.Next
/= null then
268 File
.Next
.Prev
:= File
.Prev
;
271 -- Deallocate some parts of the file structure that were kept in heap
272 -- storage with the exception of system files (standard input, output
273 -- and error) since they had some information allocated in the stack.
275 if not File
.Is_System_File
then
276 Free_String
(File
.Name
);
277 Free_String
(File
.Form
);
283 if Close_Status
/= 0 then
299 procedure Delete
(File
: in out AFCB_Ptr
) is
301 Check_File_Open
(File
);
303 if not File
.Is_Regular_File
then
308 Filename
: aliased constant String := File
.Name
.all;
313 -- Now unlink the external file. Note that we use the full name
314 -- in this unlink, because the working directory may have changed
315 -- since we did the open, and we want to unlink the right file!
317 if unlink
(Filename
'Address) = -1 then
327 function End_Of_File
(File
: AFCB_Ptr
) return Boolean is
329 Check_File_Open
(File
);
331 if feof
(File
.Stream
) /= 0 then
335 Check_Read_Status
(File
);
337 if ungetc
(fgetc
(File
.Stream
), File
.Stream
) = EOF
then
338 clearerr
(File
.Stream
);
350 -- Note: we do not need to worry about locking against multiple task
351 -- access in this routine, since it is called only from the environment
352 -- task just before terminating execution.
354 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
) is
355 pragma Warnings
(Off
, V
);
361 pragma Unreferenced
(Discard
);
364 -- Take a lock to protect global Open_Files data structure
368 -- First close all open files (the slightly complex form of this loop
369 -- is required because Close as a side effect nulls out its argument)
372 while Fptr1
/= null loop
378 -- Now unlink all temporary files. We do not bother to free the
379 -- blocks because we are just about to terminate the program. We
380 -- also ignore any errors while attempting these unlink operations.
382 while Temp_Files
/= null loop
383 Discard
:= unlink
(Temp_Files
.Name
'Address);
384 Temp_Files
:= Temp_Files
.Next
;
399 procedure Flush
(File
: AFCB_Ptr
) is
401 Check_Write_Status
(File
);
403 if fflush
(File
.Stream
) = 0 then
414 -- The fopen mode to be used is shown by the following table:
417 -- Append_File "r+" "w+"
419 -- Out_File (Direct_IO) "r+" "w"
420 -- Out_File (all others) "w" "w"
421 -- Inout_File "r+" "w+"
423 -- Note: we do not use "a" or "a+" for Append_File, since this would not
424 -- work in the case of stream files, where even if in append file mode,
425 -- you can reset to earlier points in the file. The caller must use the
426 -- Append_Set routine to deal with the necessary positioning.
428 -- Note: in several cases, the fopen mode used allows reading and
429 -- writing, but the setting of the Ada mode is more restrictive. For
430 -- instance, Create in In_File mode uses "w+" which allows writing,
431 -- but the Ada mode In_File will cause any write operations to be
432 -- rejected with Mode_Error in any case.
434 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
435 -- an initial call will be made by the caller to first open the file in
436 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
437 -- then destroy this file. This is peculiar, but that's what Ada semantics
438 -- require and the ACVT tests insist on!
440 -- If text file translation is required, then either b or t is
441 -- added to the mode, depending on the setting of Text.
448 Fopstr
: out Fopen_String
)
465 if Amethod
= 'D' and not Creat
then
474 when Inout_File | Append_File
=>
486 -- If text_translation_required is true then we need to append
487 -- either a t or b to the string to get the right mode
489 if text_translation_required
then
491 Fopstr
(Fptr
) := 't';
493 Fopstr
(Fptr
) := 'b';
499 Fopstr
(Fptr
) := ASCII
.NUL
;
506 function Form
(File
: AFCB_Ptr
) return String is
511 return File
.Form
.all (1 .. File
.Form
'Length - 1);
519 function Form_Boolean
526 pragma Unreferenced
(V2
);
529 Form_Parameter
(Form
, Keyword
, V1
, V2
);
534 elsif Form
(V1
) = 'y' then
537 elsif Form
(V1
) = 'n' then
549 function Form_Integer
559 Form_Parameter
(Form
, Keyword
, V1
, V2
);
567 for J
in V1
.. V2
loop
568 if Form
(J
) not in '0' .. '9' then
571 V
:= V
* 10 + Character'Pos (Form
(J
)) - Character'Pos ('0');
587 procedure Form_Parameter
593 Klen
: constant Integer := Keyword
'Length;
595 -- Start of processing for Form_Parameter
598 for J
in Form
'First + Klen
.. Form
'Last - 1 loop
600 and then Form
(J
- Klen
.. J
- 1) = Keyword
605 while Form
(Stop
+ 1) /= ASCII
.NUL
606 and then Form
(Stop
+ 1) /= ','
623 function Is_Open
(File
: AFCB_Ptr
) return Boolean is
625 -- We return True if the file is open, and the underlying file stream is
626 -- usable. In particular on Windows an application linked with -mwindows
627 -- option set does not have a console attached. In this case standard
628 -- files (Current_Output, Current_Error, Current_Input) are not created.
629 -- We want Is_Open (Current_Output) to return False in this case.
631 return File
/= null and then fileno
(File
.Stream
) /= -1;
638 procedure Make_Buffered
640 Buf_Siz
: Interfaces
.C_Streams
.size_t
)
643 pragma Unreferenced
(status
);
646 status
:= setvbuf
(File
.Stream
, Null_Address
, IOFBF
, Buf_Siz
);
649 ------------------------
650 -- Make_Line_Buffered --
651 ------------------------
653 procedure Make_Line_Buffered
655 Line_Siz
: Interfaces
.C_Streams
.size_t
)
658 pragma Unreferenced
(status
);
661 status
:= setvbuf
(File
.Stream
, Null_Address
, IOLBF
, Line_Siz
);
662 end Make_Line_Buffered
;
664 ---------------------
665 -- Make_Unbuffered --
666 ---------------------
668 procedure Make_Unbuffered
(File
: AFCB_Ptr
) is
670 pragma Unreferenced
(status
);
673 status
:= setvbuf
(File
.Stream
, Null_Address
, IONBF
, 0);
680 function Mode
(File
: AFCB_Ptr
) return File_Mode
is
693 function Name
(File
: AFCB_Ptr
) return String is
698 return File
.Name
.all (1 .. File
.Name
'Length - 1);
707 (File_Ptr
: in out AFCB_Ptr
;
708 Dummy_FCB
: AFCB
'Class;
715 C_Stream
: FILEs
:= NULL_Stream
)
717 pragma Warnings
(Off
, Dummy_FCB
);
718 -- Yes we know this is never assigned a value. That's intended, since
719 -- all we ever use of this value is the tag for dispatching purposes.
721 procedure Tmp_Name
(Buffer
: Address
);
722 pragma Import
(C
, Tmp_Name
, "__gnat_tmp_name");
723 -- set buffer (a String address) with a temporary filename
725 Stream
: FILEs
:= C_Stream
;
726 -- Stream which we open in response to this request
728 Shared
: Shared_Status_Type
;
729 -- Setting of Shared_Status field for file
731 Fopstr
: aliased Fopen_String
;
732 -- Mode string used in fopen call
734 Formstr
: aliased String (1 .. Form
'Length + 1);
735 -- Form string with ASCII.NUL appended, folded to lower case
737 Tempfile
: constant Boolean := (Name
'Length = 0);
738 -- Indicates temporary file case
740 Namelen
: constant Integer := max_path_len
;
741 -- Length required for file name, not including final ASCII.NUL
742 -- Note that we used to reference L_tmpnam here, which is not
743 -- reliable since __gnat_tmp_name does not always use tmpnam.
745 Namestr
: aliased String (1 .. Namelen
+ 1);
746 -- Name as given or temporary file name with ASCII.NUL appended
748 Fullname
: aliased String (1 .. max_path_len
+ 1);
749 -- Full name (as required for Name function, and as stored in the
750 -- control block in the Name field) with ASCII.NUL appended.
752 Full_Name_Len
: Integer;
753 -- Length of name actually stored in Fullname
755 Encoding
: System
.CRTL
.Filename_Encoding
;
756 -- Filename encoding specified into the form parameter
759 if File_Ptr
/= null then
763 -- Acquire form string, setting required NUL terminator
765 Formstr
(1 .. Form
'Length) := Form
;
766 Formstr
(Formstr
'Last) := ASCII
.NUL
;
768 -- Convert form string to lower case
770 for J
in Formstr
'Range loop
771 if Formstr
(J
) in 'A' .. 'Z' then
772 Formstr
(J
) := Character'Val (Character'Pos (Formstr
(J
)) + 32);
776 -- Acquire setting of shared parameter
782 Form_Parameter
(Formstr
, "shared", V1
, V2
);
787 elsif Formstr
(V1
.. V2
) = "yes" then
790 elsif Formstr
(V1
.. V2
) = "no" then
798 -- Acquire setting of shared parameter
804 Form_Parameter
(Formstr
, "encoding", V1
, V2
);
807 Encoding
:= System
.CRTL
.UTF8
;
809 elsif Formstr
(V1
.. V2
) = "utf8" then
810 Encoding
:= System
.CRTL
.UTF8
;
812 elsif Formstr
(V1
.. V2
) = "8bits" then
813 Encoding
:= System
.CRTL
.ASCII_8bits
;
820 -- If we were given a stream (call from xxx.C_Streams.Open), then set
821 -- the full name to the given one, and skip to end of processing.
823 if Stream
/= NULL_Stream
then
824 Full_Name_Len
:= Name
'Length + 1;
825 Fullname
(1 .. Full_Name_Len
- 1) := Name
;
826 Fullname
(Full_Name_Len
) := ASCII
.Nul
;
828 -- Normal case of Open or Create
831 -- If temporary file case, get temporary file name and add
832 -- to the list of temporary files to be deleted on exit.
839 Tmp_Name
(Namestr
'Address);
841 if Namestr
(1) = ASCII
.NUL
then
845 -- Chain to temp file list, ensuring thread safety with a lock
850 new Temp_File_Record
'(Name => Namestr, Next => Temp_Files);
859 -- Normal case of non-null name given
862 if Name'Length > Namelen then
866 Namestr (1 .. Name'Length) := Name;
867 Namestr (Name'Length + 1) := ASCII.NUL;
870 -- Get full name in accordance with the advice of RM A.8.2(22)
872 full_name (Namestr'Address, Fullname'Address);
874 if Fullname (1) = ASCII.NUL then
879 while Full_Name_Len < Fullname'Last
880 and then Fullname (Full_Name_Len) /= ASCII.NUL
882 Full_Name_Len := Full_Name_Len + 1;
885 -- Fullname is generated by calling system's full_name. The problem
886 -- is, full_name does nothing about the casing, so a file name
887 -- comparison may generally speaking not be valid on non-case
888 -- sensitive systems, and in particular we get unexpected failures
889 -- on Windows/Vista because of this. So we use s-casuti to force
890 -- the name to lower case.
892 if not File_Names_Case_Sensitive then
893 To_Lower (Fullname (1 .. Full_Name_Len));
896 -- If Shared=None or Shared=Yes, then check for the existence
897 -- of another file with exactly the same full name.
904 -- Take a task lock to protect Open_Files
908 -- Search list of open files
912 if Fullname (1 .. Full_Name_Len) = P.Name.all then
914 -- If we get a match, and either file has Shared=None,
915 -- then raise Use_Error, since we don't allow two files
916 -- of the same name to be opened unless they specify the
917 -- required sharing mode.
920 or else P.Shared_Status = None
924 -- If both files have Shared=Yes, then we acquire the
925 -- stream from the located file to use as our stream.
928 and then P.Shared_Status = Yes
933 -- Otherwise one of the files has Shared=Yes and one has
934 -- Shared=No. If the current file has Shared=No then all
935 -- is well but we don't want to share any other file's
936 -- stream. If the current file has Shared=Yes, we would
937 -- like to share a stream, but not from a file that has
938 -- Shared=No, so either way, we just continue the search.
957 -- Open specified file if we did not find an existing stream
959 if Stream = NULL_Stream then
960 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
962 -- A special case, if we are opening (OPEN case) a file and the
963 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
964 -- make sure that the file exists as required by Ada semantics.
966 if Creat = False and then Fopstr (1) /= 'r
' then
967 if file_exists (Namestr'Address) = 0 then
972 -- Now open the file. Note that we use the name as given in the
973 -- original Open call for this purpose, since that seems the
974 -- clearest implementation of the intent. It would presumably
975 -- work to use the full name here, but if there is any difference,
976 -- then we should use the name used in the call.
978 -- Note: for a corresponding delete, we will use the full name,
979 -- since by the time of the delete, the current working directory
980 -- may have changed and we do not want to delete a different file!
982 Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
984 if Stream = NULL_Stream then
985 if file_exists (Namestr'Address) = 0 then
994 -- Stream has been successfully located or opened, so now we are
995 -- committed to completing the opening of the file. Allocate block
996 -- on heap and fill in its fields.
998 File_Ptr := AFCB_Allocate (Dummy_FCB);
1000 File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0);
1001 File_Ptr.Is_System_File := False;
1002 File_Ptr.Is_Text_File := Text;
1003 File_Ptr.Shared_Status := Shared;
1004 File_Ptr.Access_Method := Amethod;
1005 File_Ptr.Stream := Stream;
1006 File_Ptr.Form := new String'(Formstr
);
1007 File_Ptr
.Name
:= new String'(Fullname (1 .. Full_Name_Len));
1008 File_Ptr.Mode := Mode;
1009 File_Ptr.Is_Temporary_File := Tempfile;
1010 File_Ptr.Encoding := Encoding;
1012 Chain_File (File_Ptr);
1013 Append_Set (File_Ptr);
1020 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1024 Nread := fread (Buf, 1, Siz, File.Stream);
1029 elsif ferror (File.Stream) /= 0 then
1032 elsif Nread = 0 then
1035 else -- 0 < Nread < Siz
1044 Siz : Interfaces.C_Streams.size_t;
1045 Count : out Interfaces.C_Streams.size_t)
1048 Count := fread (Buf, 1, Siz, File.Stream);
1050 if Count = 0 and then ferror (File.Stream) /= 0 then
1059 -- The reset which does not change the mode simply does a rewind
1061 procedure Reset (File : in out AFCB_Ptr) is
1063 Check_File_Open (File);
1064 Reset (File, File.Mode);
1067 -- The reset with a change in mode is done using freopen, and is
1068 -- not permitted except for regular files (since otherwise there
1069 -- is no name for the freopen, and in any case it seems meaningless)
1071 procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is
1072 Fopstr : aliased Fopen_String;
1075 Check_File_Open (File);
1077 -- Change of mode not allowed for shared file or file with no name
1078 -- or file that is not a regular file, or for a system file.
1080 if File.Shared_Status = Yes
1081 or else File.Name'Length <= 1
1082 or else File.Is_System_File
1083 or else not File.Is_Regular_File
1087 -- For In_File or Inout_File for a regular file, we can just do a
1088 -- rewind if the mode is unchanged, which is more efficient than
1089 -- doing a full reopen.
1091 elsif Mode = File.Mode
1092 and then Mode <= Inout_File
1094 rewind (File.Stream);
1096 -- Here the change of mode is permitted, we do it by reopening the
1097 -- file in the new mode and replacing the stream with a new stream.
1101 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1103 File.Stream := freopen
1104 (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
1106 if File.Stream = NULL_Stream then
1121 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1123 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1124 -- call could be reversed, but on VMS, this is a better choice, since
1125 -- for some file formats, reversing the parameters results in records
1126 -- of one byte each.
1128 SSL.Abort_Defer.all;
1130 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1132 SSL.Abort_Undefer.all;
1137 SSL.Abort_Undefer.all;