1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2002 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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
;
37 with System
.Soft_Links
;
38 with Unchecked_Deallocation
;
40 package body System
.File_IO
is
42 use System
.File_Control_Block
;
44 package SSL
renames System
.Soft_Links
;
46 ----------------------
47 -- Global Variables --
48 ----------------------
50 Open_Files
: AFCB_Ptr
;
51 -- This points to a list of AFCB's for all open files. This is a doubly
52 -- linked list, with the Prev pointer of the first entry, and the Next
53 -- pointer of the last entry containing null. Note that this global
54 -- variable must be properly protected to provide thread safety.
56 type Temp_File_Record
;
57 type Temp_File_Record_Ptr
is access all Temp_File_Record
;
59 type Temp_File_Record
is record
60 Name
: String (1 .. L_tmpnam
+ 1);
61 Next
: Temp_File_Record_Ptr
;
63 -- One of these is allocated for each temporary file created
65 Temp_Files
: Temp_File_Record_Ptr
;
66 -- Points to list of names of temporary files. Note that this global
67 -- variable must be properly protected to provide thread safety.
69 type File_IO_Clean_Up_Type
is new Controlled
with null record;
70 -- The closing of all open files and deletion of temporary files is an
71 -- action which takes place at the end of execution of the main program.
72 -- This action can be implemented using a library level object which
73 -- gets finalized at the end of the main program execution. The above is
74 -- a controlled type introduced for this purpose.
76 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
);
77 -- This is the finalize operation that is used to do the cleanup.
79 File_IO_Clean_Up_Object
: File_IO_Clean_Up_Type
;
80 pragma Warnings
(Off
, File_IO_Clean_Up_Object
);
81 -- This is the single object of the type that triggers the finalization
82 -- call. Since it is at the library level, this happens just before the
83 -- environment task is finalized.
85 text_translation_required
: Boolean;
87 (C
, text_translation_required
, "__gnat_text_translation_required");
88 -- If true, add appropriate suffix to control string for Open.
90 -----------------------
91 -- Local Subprograms --
92 -----------------------
94 procedure Free_String
is new Unchecked_Deallocation
(String, Pstring
);
96 subtype Fopen_String
is String (1 .. 4);
97 -- Holds open string (longest is "w+b" & nul)
104 Fopstr
: out Fopen_String
);
105 -- Determines proper open mode for a file to be opened in the given
106 -- Ada mode. Text is true for a text file and false otherwise, and
107 -- Creat is true for a create call, and False for an open call. The
108 -- value stored in Fopstr is a nul-terminated string suitable for a
109 -- call to fopen or freopen. Amethod is the character designating
110 -- the access method from the Access_Method field of the FCB.
116 procedure Append_Set
(File
: AFCB_Ptr
) is
118 if File
.Mode
= Append_File
then
119 if fseek
(File
.Stream
, 0, SEEK_END
) /= 0 then
129 procedure Chain_File
(File
: AFCB_Ptr
) is
131 -- Take a task lock, to protect the global data value Open_Files
132 -- No exception handler needed, since we cannot get an exception.
135 File
.Next
:= Open_Files
;
139 if File
.Next
/= null then
140 File
.Next
.Prev
:= File
;
146 ---------------------
147 -- Check_File_Open --
148 ---------------------
150 procedure Check_File_Open
(File
: AFCB_Ptr
) is
157 -----------------------
158 -- Check_Read_Status --
159 -----------------------
161 procedure Check_Read_Status
(File
: AFCB_Ptr
) is
165 elsif File
.Mode
> Inout_File
then
168 end Check_Read_Status
;
170 ------------------------
171 -- Check_Write_Status --
172 ------------------------
174 procedure Check_Write_Status
(File
: AFCB_Ptr
) is
178 elsif File
.Mode
= In_File
then
181 end Check_Write_Status
;
187 procedure Close
(File
: in out AFCB_Ptr
) is
188 Close_Status
: int
:= 0;
189 Dup_Strm
: Boolean := False;
192 Check_File_Open
(File
);
195 -- Sever the association between the given file and its associated
196 -- external file. The given file is left closed. Do not perform system
197 -- closes on the standard input, output and error files and also do
198 -- not attempt to close a stream that does not exist (signalled by a
199 -- null stream value -- happens in some error situations).
201 if not File
.Is_System_File
202 and then File
.Stream
/= NULL_Stream
204 -- Do not do an fclose if this is a shared file and there is
205 -- at least one other instance of the stream that is open.
207 if File
.Shared_Status
= Yes
then
215 and then File
.Stream
= P
.Stream
226 -- Do the fclose unless this was a duplicate in the shared case
229 Close_Status
:= fclose
(File
.Stream
);
233 -- Dechain file from list of open files and then free the storage
234 -- Since this is a global data structure, we have to protect against
235 -- multiple tasks attempting to access this list.
237 -- Note that we do not use an exception handler to unlock here since
238 -- no exception can occur inside the lock/unlock pair.
243 if File
.Prev
= null then
244 Open_Files
:= File
.Next
;
246 File
.Prev
.Next
:= File
.Next
;
249 if File
.Next
/= null then
250 File
.Next
.Prev
:= File
.Prev
;
256 -- Deallocate some parts of the file structure that were kept in heap
257 -- storage with the exception of system files (standard input, output
258 -- and error) since they had some information allocated in the stack.
260 if not File
.Is_System_File
then
261 Free_String
(File
.Name
);
262 Free_String
(File
.Form
);
268 if Close_Status
/= 0 then
277 procedure Delete
(File
: in out AFCB_Ptr
) is
279 Check_File_Open
(File
);
281 if not File
.Is_Regular_File
then
286 Filename
: aliased constant String := File
.Name
.all;
291 -- Now unlink the external file. Note that we use the full name
292 -- in this unlink, because the working directory may have changed
293 -- since we did the open, and we want to unlink the right file!
295 if unlink
(Filename
'Address) = -1 then
305 function End_Of_File
(File
: AFCB_Ptr
) return Boolean is
307 Check_File_Open
(File
);
309 if feof
(File
.Stream
) /= 0 then
313 Check_Read_Status
(File
);
315 if ungetc
(fgetc
(File
.Stream
), File
.Stream
) = EOF
then
316 clearerr
(File
.Stream
);
328 -- Note: we do not need to worry about locking against multiple task
329 -- access in this routine, since it is called only from the environment
330 -- task just before terminating execution.
332 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
) is
333 pragma Warnings
(Off
, V
);
340 -- First close all open files (the slightly complex form of this loop
341 -- is required because Close as a side effect nulls out its argument)
344 while Fptr1
/= null loop
350 -- Now unlink all temporary files. We do not bother to free the
351 -- blocks because we are just about to terminate the program. We
352 -- also ignore any errors while attempting these unlink operations.
354 while Temp_Files
/= null loop
355 Discard
:= unlink
(Temp_Files
.Name
'Address);
356 Temp_Files
:= Temp_Files
.Next
;
365 procedure Flush
(File
: AFCB_Ptr
) is
367 Check_Write_Status
(File
);
369 if fflush
(File
.Stream
) = 0 then
380 -- The fopen mode to be used is shown by the following table:
383 -- Append_File "r+" "w+"
385 -- Out_File (Direct_IO) "r+" "w"
386 -- Out_File (all others) "w" "w"
387 -- Inout_File "r+" "w+"
389 -- Note: we do not use "a" or "a+" for Append_File, since this would not
390 -- work in the case of stream files, where even if in append file mode,
391 -- you can reset to earlier points in the file. The caller must use the
392 -- Append_Set routine to deal with the necessary positioning.
394 -- Note: in several cases, the fopen mode used allows reading and
395 -- writing, but the setting of the Ada mode is more restrictive. For
396 -- instance, Create in In_File mode uses "w+" which allows writing,
397 -- but the Ada mode In_File will cause any write operations to be
398 -- rejected with Mode_Error in any case.
400 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
401 -- an initial call will be made by the caller to first open the file in
402 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
403 -- then destroy this file. This is peculiar, but that's what Ada semantics
404 -- require and the ACVT tests insist on!
406 -- If text file translation is required, then either b or t is
407 -- added to the mode, depending on the setting of Text.
414 Fopstr
: out Fopen_String
)
431 if Amethod
= 'D' and not Creat
then
440 when Inout_File | Append_File
=>
452 -- If text_translation_required is true then we need to append
453 -- either a t or b to the string to get the right mode
455 if text_translation_required
then
457 Fopstr
(Fptr
) := 't';
459 Fopstr
(Fptr
) := 'b';
465 Fopstr
(Fptr
) := ASCII
.NUL
;
472 function Form
(File
: in AFCB_Ptr
) return String is
477 return File
.Form
.all (1 .. File
.Form
'Length - 1);
485 function Form_Boolean
494 Form_Parameter
(Form
, Keyword
, V1
, V2
);
499 elsif Form
(V1
) = 'y' then
502 elsif Form
(V1
) = 'n' then
514 function Form_Integer
524 Form_Parameter
(Form
, Keyword
, V1
, V2
);
532 for J
in V1
.. V2
loop
533 if Form
(J
) not in '0' .. '9' then
536 V
:= V
* 10 + Character'Pos (Form
(J
)) - Character'Pos ('0');
552 procedure Form_Parameter
558 Klen
: constant Integer := Keyword
'Length;
560 -- Start of processing for Form_Parameter
563 for J
in Form
'First + Klen
.. Form
'Last - 1 loop
565 and then Form
(J
- Klen
.. J
- 1) = Keyword
570 while Form
(Stop
+ 1) /= ASCII
.NUL
571 and then Form
(Stop
+ 1) /= ','
588 function Is_Open
(File
: in AFCB_Ptr
) return Boolean is
590 return (File
/= null);
597 procedure Make_Buffered
599 Buf_Siz
: Interfaces
.C_Streams
.size_t
) is
603 status
:= setvbuf
(File
.Stream
, Null_Address
, IOFBF
, Buf_Siz
);
606 ------------------------
607 -- Make_Line_Buffered --
608 ------------------------
610 procedure Make_Line_Buffered
612 Line_Siz
: Interfaces
.C_Streams
.size_t
) is
616 status
:= setvbuf
(File
.Stream
, Null_Address
, IOLBF
, Line_Siz
);
617 end Make_Line_Buffered
;
619 ---------------------
620 -- Make_Unbuffered --
621 ---------------------
623 procedure Make_Unbuffered
(File
: AFCB_Ptr
) is
627 status
:= setvbuf
(File
.Stream
, Null_Address
, IONBF
, 0);
634 function Mode
(File
: in AFCB_Ptr
) return File_Mode
is
647 function Name
(File
: in AFCB_Ptr
) return String is
652 return File
.Name
.all (1 .. File
.Name
'Length - 1);
661 (File_Ptr
: in out AFCB_Ptr
;
662 Dummy_FCB
: in out AFCB
'Class;
669 C_Stream
: FILEs
:= NULL_Stream
)
671 procedure Tmp_Name
(Buffer
: Address
);
672 pragma Import
(C
, Tmp_Name
, "__gnat_tmp_name");
673 -- set buffer (a String address) with a temporary filename.
675 Stream
: FILEs
:= C_Stream
;
676 -- Stream which we open in response to this request
678 Shared
: Shared_Status_Type
;
679 -- Setting of Shared_Status field for file
681 Fopstr
: aliased Fopen_String
;
682 -- Mode string used in fopen call
684 Formstr
: aliased String (1 .. Form
'Length + 1);
685 -- Form string with ASCII.NUL appended, folded to lower case
687 Tempfile
: constant Boolean := (Name
'Length = 0);
688 -- Indicates temporary file case
690 Namelen
: constant Integer := max_path_len
;
691 -- Length required for file name, not including final ASCII.NUL
692 -- Note that we used to reference L_tmpnam here, which is not
693 -- reliable since __gnat_tmp_name does not always use tmpnam.
695 Namestr
: aliased String (1 .. Namelen
+ 1);
696 -- Name as given or temporary file name with ASCII.NUL appended
698 Fullname
: aliased String (1 .. max_path_len
+ 1);
699 -- Full name (as required for Name function, and as stored in the
700 -- control block in the Name field) with ASCII.NUL appended.
702 Full_Name_Len
: Integer;
703 -- Length of name actually stored in Fullname
706 if File_Ptr
/= null then
710 -- Acquire form string, setting required NUL terminator
712 Formstr
(1 .. Form
'Length) := Form
;
713 Formstr
(Formstr
'Last) := ASCII
.NUL
;
715 -- Convert form string to lower case
717 for J
in Formstr
'Range loop
718 if Formstr
(J
) in 'A' .. 'Z' then
719 Formstr
(J
) := Character'Val (Character'Pos (Formstr
(J
)) + 32);
723 -- Acquire setting of shared parameter
729 Form_Parameter
(Formstr
, "shared", V1
, V2
);
734 elsif Formstr
(V1
.. V2
) = "yes" then
737 elsif Formstr
(V1
.. V2
) = "no" then
745 -- If we were given a stream (call from xxx.C_Streams.Open), then set
746 -- full name to null and that is all we have to do in this case so
747 -- skip to end of processing.
749 if Stream
/= NULL_Stream
then
750 Fullname
(1) := ASCII
.Nul
;
753 -- Normal case of Open or Create
756 -- If temporary file case, get temporary file name and add
757 -- to the list of temporary files to be deleted on exit.
764 Tmp_Name
(Namestr
'Address);
766 if Namestr
(1) = ASCII
.NUL
then
770 -- Chain to temp file list, ensuring thread safety with a lock
775 new Temp_File_Record
'(Name => Namestr, Next => Temp_Files);
784 -- Normal case of non-null name given
787 Namestr (1 .. Name'Length) := Name;
788 Namestr (Name'Length + 1) := ASCII.NUL;
791 -- Get full name in accordance with the advice of RM A.8.2(22).
793 full_name (Namestr'Address, Fullname'Address);
795 if Fullname (1) = ASCII.NUL then
800 while Full_Name_Len < Fullname'Last
801 and then Fullname (Full_Name_Len) /= ASCII.NUL
803 Full_Name_Len := Full_Name_Len + 1;
806 -- If Shared=None or Shared=Yes, then check for the existence
807 -- of another file with exactly the same full name.
816 if Fullname (1 .. Full_Name_Len) = P.Name.all then
818 -- If we get a match, and either file has Shared=None,
819 -- then raise Use_Error, since we don't allow two
820 -- files of the same name to be opened unless they
821 -- specify the required sharing mode.
824 or else P.Shared_Status = None
828 -- If both files have Shared=Yes, then we acquire the
829 -- stream from the located file to use as our stream.
832 and then P.Shared_Status = Yes
837 -- Otherwise one of the files has Shared=Yes and one
838 -- has Shared=No. If the current file has Shared=No
839 -- then all is well but we don't want to share any
840 -- other file's stream. If the current file has
841 -- Shared=Yes, we would like to share a stream, but
842 -- not from a file that has Shared=No, so in either
843 -- case we just keep going on the search.
855 -- Open specified file if we did not find an existing stream
857 if Stream = NULL_Stream then
858 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
860 -- A special case, if we are opening (OPEN case) a file and
861 -- the mode returned by Fopen_Mode is not "r" or "r+", then
862 -- we first make sure that the file exists as required by
865 if Creat = False and then Fopstr (1) /= 'r
' then
866 if file_exists (Namestr'Address) = 0 then
871 -- Now open the file. Note that we use the name as given
872 -- in the original Open call for this purpose, since that
873 -- seems the clearest implementation of the intent. It
874 -- would presumably work to use the full name here, but
875 -- if there is any difference, then we should use the
876 -- name used in the call.
878 -- Note: for a corresponding delete, we will use the
879 -- full name, since by the time of the delete, the
880 -- current working directory may have changed and
881 -- we do not want to delete a different file!
883 Stream := fopen (Namestr'Address, Fopstr'Address);
885 if Stream = NULL_Stream then
886 if file_exists (Namestr'Address) = 0 then
895 -- Stream has been successfully located or opened, so now we are
896 -- committed to completing the opening of the file. Allocate block
897 -- on heap and fill in its fields.
899 File_Ptr := AFCB_Allocate (Dummy_FCB);
901 File_Ptr.Is_Regular_File := (is_regular_file
902 (fileno (Stream)) /= 0);
903 File_Ptr.Is_System_File := False;
904 File_Ptr.Is_Text_File := Text;
905 File_Ptr.Shared_Status := Shared;
906 File_Ptr.Access_Method := Amethod;
907 File_Ptr.Stream := Stream;
908 File_Ptr.Form := new String'(Formstr
);
909 File_Ptr
.Name
:= new String'(Fullname
910 (1 .. Full_Name_Len));
911 File_Ptr.Mode := Mode;
912 File_Ptr.Is_Temporary_File := Tempfile;
914 Chain_File (File_Ptr);
915 Append_Set (File_Ptr);
922 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
926 Nread := fread (Buf, 1, Siz, File.Stream);
931 elsif ferror (File.Stream) /= 0 then
937 else -- 0 < Nread < Siz
946 Siz : in Interfaces.C_Streams.size_t;
947 Count : out Interfaces.C_Streams.size_t)
950 Count := fread (Buf, 1, Siz, File.Stream);
952 if Count = 0 and then ferror (File.Stream) /= 0 then
961 -- The reset which does not change the mode simply does a rewind.
963 procedure Reset (File : in out AFCB_Ptr) is
965 Check_File_Open (File);
966 Reset (File, File.Mode);
969 -- The reset with a change in mode is done using freopen, and is
970 -- not permitted except for regular files (since otherwise there
971 -- is no name for the freopen, and in any case it seems meaningless)
973 procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is
974 Fopstr : aliased Fopen_String;
977 Check_File_Open (File);
979 -- Change of mode not allowed for shared file or file with no name
980 -- or file that is not a regular file, or for a system file.
982 if File.Shared_Status = Yes
983 or else File.Name'Length <= 1
984 or else File.Is_System_File
985 or else (not File.Is_Regular_File)
989 -- For In_File or Inout_File for a regular file, we can just do a
990 -- rewind if the mode is unchanged, which is more efficient than
991 -- doing a full reopen.
993 elsif Mode = File.Mode
994 and then Mode <= Inout_File
996 rewind (File.Stream);
998 -- Here the change of mode is permitted, we do it by reopening the
999 -- file in the new mode and replacing the stream with a new stream.
1003 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1006 freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
1008 if File.Stream = NULL_Stream then
1023 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1025 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1026 -- call could be reversed, but on VMS, this is a better choice, since
1027 -- for some file formats, reversing the parameters results in records
1028 -- of one byte each.
1030 SSL.Abort_Defer.all;
1032 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1034 SSL.Abort_Undefer.all;
1039 SSL.Abort_Undefer.all;