1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 with Ada
.Finalization
; use Ada
.Finalization
;
36 with Ada
.IO_Exceptions
; use Ada
.IO_Exceptions
;
37 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
38 with System
.Soft_Links
;
39 with Unchecked_Deallocation
;
41 package body System
.File_IO
is
43 use System
.File_Control_Block
;
45 package SSL
renames System
.Soft_Links
;
47 ----------------------
48 -- Global Variables --
49 ----------------------
51 Open_Files
: AFCB_Ptr
;
52 -- This points to a list of AFCB's for all open files. This is a doubly
53 -- linked list, with the Prev pointer of the first entry, and the Next
54 -- pointer of the last entry containing null. Note that this global
55 -- variable must be properly protected to provide thread safety.
57 type Temp_File_Record
;
58 type Temp_File_Record_Ptr
is access all Temp_File_Record
;
60 type Temp_File_Record
is record
61 Name
: String (1 .. L_tmpnam
+ 1);
62 Next
: Temp_File_Record_Ptr
;
64 -- One of these is allocated for each temporary file created
66 Temp_Files
: Temp_File_Record_Ptr
;
67 -- Points to list of names of temporary files. Note that this global
68 -- variable must be properly protected to provide thread safety.
70 type File_IO_Clean_Up_Type
is new Controlled
with null record;
71 -- The closing of all open files and deletion of temporary files is an
72 -- action which takes place at the end of execution of the main program.
73 -- This action can be implemented using a library level object which
74 -- gets finalized at the end of the main program execution. The above is
75 -- a controlled type introduced for this purpose.
77 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
);
78 -- This is the finalize operation that is used to do the cleanup.
80 File_IO_Clean_Up_Object
: File_IO_Clean_Up_Type
;
81 pragma Warnings
(Off
, File_IO_Clean_Up_Object
);
82 -- This is the single object of the type that triggers the finalization
83 -- call. Since it is at the library level, this happens just before the
84 -- environment task is finalized.
86 text_translation_required
: Boolean;
88 (C
, text_translation_required
, "__gnat_text_translation_required");
89 -- If true, add appropriate suffix to control string for Open.
91 -----------------------
92 -- Local Subprograms --
93 -----------------------
95 procedure Free_String
is new Unchecked_Deallocation
(String, Pstring
);
97 subtype Fopen_String
is String (1 .. 4);
98 -- Holds open string (longest is "w+b" & nul)
105 Fopstr
: out Fopen_String
);
106 -- Determines proper open mode for a file to be opened in the given
107 -- Ada mode. Text is true for a text file and false otherwise, and
108 -- Creat is true for a create call, and False for an open call. The
109 -- value stored in Fopstr is a nul-terminated string suitable for a
110 -- call to fopen or freopen. Amethod is the character designating
111 -- the access method from the Access_Method field of the FCB.
117 procedure Append_Set
(File
: AFCB_Ptr
) is
119 if File
.Mode
= Append_File
then
120 if fseek
(File
.Stream
, 0, SEEK_END
) /= 0 then
130 procedure Chain_File
(File
: AFCB_Ptr
) is
132 -- Take a task lock, to protect the global data value Open_Files
133 -- No exception handler needed, since we cannot get an exception.
136 File
.Next
:= Open_Files
;
140 if File
.Next
/= null then
141 File
.Next
.Prev
:= File
;
147 ---------------------
148 -- Check_File_Open --
149 ---------------------
151 procedure Check_File_Open
(File
: AFCB_Ptr
) is
158 -----------------------
159 -- Check_Read_Status --
160 -----------------------
162 procedure Check_Read_Status
(File
: AFCB_Ptr
) is
166 elsif File
.Mode
> Inout_File
then
169 end Check_Read_Status
;
171 ------------------------
172 -- Check_Write_Status --
173 ------------------------
175 procedure Check_Write_Status
(File
: AFCB_Ptr
) is
179 elsif File
.Mode
= In_File
then
182 end Check_Write_Status
;
188 procedure Close
(File
: in out AFCB_Ptr
) is
189 Close_Status
: int
:= 0;
190 Dup_Strm
: Boolean := False;
193 Check_File_Open
(File
);
196 -- Sever the association between the given file and its associated
197 -- external file. The given file is left closed. Do not perform system
198 -- closes on the standard input, output and error files and also do
199 -- not attempt to close a stream that does not exist (signalled by a
200 -- null stream value -- happens in some error situations).
202 if not File
.Is_System_File
203 and then File
.Stream
/= NULL_Stream
205 -- Do not do an fclose if this is a shared file and there is
206 -- at least one other instance of the stream that is open.
208 if File
.Shared_Status
= Yes
then
216 and then File
.Stream
= P
.Stream
227 -- Do the fclose unless this was a duplicate in the shared case
230 Close_Status
:= fclose
(File
.Stream
);
234 -- Dechain file from list of open files and then free the storage
235 -- Since this is a global data structure, we have to protect against
236 -- multiple tasks attempting to access this list.
238 -- Note that we do not use an exception handler to unlock here since
239 -- no exception can occur inside the lock/unlock pair.
244 if File
.Prev
= null then
245 Open_Files
:= File
.Next
;
247 File
.Prev
.Next
:= File
.Next
;
250 if File
.Next
/= null then
251 File
.Next
.Prev
:= File
.Prev
;
257 -- Deallocate some parts of the file structure that were kept in heap
258 -- storage with the exception of system files (standard input, output
259 -- and error) since they had some information allocated in the stack.
261 if not File
.Is_System_File
then
262 Free_String
(File
.Name
);
263 Free_String
(File
.Form
);
269 if Close_Status
/= 0 then
278 procedure Delete
(File
: in out AFCB_Ptr
) is
280 Check_File_Open
(File
);
282 if not File
.Is_Regular_File
then
287 Filename
: aliased constant String := File
.Name
.all;
292 -- Now unlink the external file. Note that we use the full name
293 -- in this unlink, because the working directory may have changed
294 -- since we did the open, and we want to unlink the right file!
296 if unlink
(Filename
'Address) = -1 then
306 function End_Of_File
(File
: AFCB_Ptr
) return Boolean is
308 Check_File_Open
(File
);
310 if feof
(File
.Stream
) /= 0 then
314 Check_Read_Status
(File
);
316 if ungetc
(fgetc
(File
.Stream
), File
.Stream
) = EOF
then
317 clearerr
(File
.Stream
);
329 -- Note: we do not need to worry about locking against multiple task
330 -- access in this routine, since it is called only from the environment
331 -- task just before terminating execution.
333 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
) is
334 pragma Warnings
(Off
, V
);
341 -- First close all open files (the slightly complex form of this loop
342 -- is required because Close as a side effect nulls out its argument)
345 while Fptr1
/= null loop
351 -- Now unlink all temporary files. We do not bother to free the
352 -- blocks because we are just about to terminate the program. We
353 -- also ignore any errors while attempting these unlink operations.
355 while Temp_Files
/= null loop
356 Discard
:= unlink
(Temp_Files
.Name
'Address);
357 Temp_Files
:= Temp_Files
.Next
;
366 procedure Flush
(File
: AFCB_Ptr
) is
368 Check_Write_Status
(File
);
370 if fflush
(File
.Stream
) = 0 then
381 -- The fopen mode to be used is shown by the following table:
384 -- Append_File "r+" "w+"
386 -- Out_File (Direct_IO) "r+" "w"
387 -- Out_File (all others) "w" "w"
388 -- Inout_File "r+" "w+"
390 -- Note: we do not use "a" or "a+" for Append_File, since this would not
391 -- work in the case of stream files, where even if in append file mode,
392 -- you can reset to earlier points in the file. The caller must use the
393 -- Append_Set routine to deal with the necessary positioning.
395 -- Note: in several cases, the fopen mode used allows reading and
396 -- writing, but the setting of the Ada mode is more restrictive. For
397 -- instance, Create in In_File mode uses "w+" which allows writing,
398 -- but the Ada mode In_File will cause any write operations to be
399 -- rejected with Mode_Error in any case.
401 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
402 -- an initial call will be made by the caller to first open the file in
403 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
404 -- then destroy this file. This is peculiar, but that's what Ada semantics
405 -- require and the ACVT tests insist on!
407 -- If text file translation is required, then either b or t is
408 -- added to the mode, depending on the setting of Text.
415 Fopstr
: out Fopen_String
)
432 if Amethod
= 'D' and not Creat
then
441 when Inout_File | Append_File
=>
453 -- If text_translation_required is true then we need to append
454 -- either a t or b to the string to get the right mode
456 if text_translation_required
then
458 Fopstr
(Fptr
) := 't';
460 Fopstr
(Fptr
) := 'b';
466 Fopstr
(Fptr
) := ASCII
.NUL
;
473 function Form
(File
: in AFCB_Ptr
) return String is
478 return File
.Form
.all (1 .. File
.Form
'Length - 1);
486 function Form_Boolean
495 Form_Parameter
(Form
, Keyword
, V1
, V2
);
500 elsif Form
(V1
) = 'y' then
503 elsif Form
(V1
) = 'n' then
515 function Form_Integer
525 Form_Parameter
(Form
, Keyword
, V1
, V2
);
533 for J
in V1
.. V2
loop
534 if Form
(J
) not in '0' .. '9' then
537 V
:= V
* 10 + Character'Pos (Form
(J
)) - Character'Pos ('0');
553 procedure Form_Parameter
559 Klen
: constant Integer := Keyword
'Length;
561 -- Start of processing for Form_Parameter
564 for J
in Form
'First + Klen
.. Form
'Last - 1 loop
566 and then Form
(J
- Klen
.. J
- 1) = Keyword
571 while Form
(Stop
+ 1) /= ASCII
.NUL
572 and then Form
(Stop
+ 1) /= ','
589 function Is_Open
(File
: in AFCB_Ptr
) return Boolean is
591 return (File
/= null);
598 procedure Make_Buffered
600 Buf_Siz
: Interfaces
.C_Streams
.size_t
) is
604 status
:= setvbuf
(File
.Stream
, Null_Address
, IOFBF
, Buf_Siz
);
607 ------------------------
608 -- Make_Line_Buffered --
609 ------------------------
611 procedure Make_Line_Buffered
613 Line_Siz
: Interfaces
.C_Streams
.size_t
) is
617 status
:= setvbuf
(File
.Stream
, Null_Address
, IOLBF
, Line_Siz
);
618 end Make_Line_Buffered
;
620 ---------------------
621 -- Make_Unbuffered --
622 ---------------------
624 procedure Make_Unbuffered
(File
: AFCB_Ptr
) is
628 status
:= setvbuf
(File
.Stream
, Null_Address
, IONBF
, 0);
635 function Mode
(File
: in AFCB_Ptr
) return File_Mode
is
648 function Name
(File
: in AFCB_Ptr
) return String is
653 return File
.Name
.all (1 .. File
.Name
'Length - 1);
662 (File_Ptr
: in out AFCB_Ptr
;
663 Dummy_FCB
: in out AFCB
'Class;
670 C_Stream
: FILEs
:= NULL_Stream
)
672 procedure Tmp_Name
(Buffer
: Address
);
673 pragma Import
(C
, Tmp_Name
, "__gnat_tmp_name");
674 -- set buffer (a String address) with a temporary filename.
676 Stream
: FILEs
:= C_Stream
;
677 -- Stream which we open in response to this request
679 Shared
: Shared_Status_Type
;
680 -- Setting of Shared_Status field for file
682 Fopstr
: aliased Fopen_String
;
683 -- Mode string used in fopen call
685 Formstr
: aliased String (1 .. Form
'Length + 1);
686 -- Form string with ASCII.NUL appended, folded to lower case
688 Tempfile
: constant Boolean := (Name
'Length = 0);
689 -- Indicates temporary file case
691 Namelen
: constant Integer := max_path_len
;
692 -- Length required for file name, not including final ASCII.NUL
693 -- Note that we used to reference L_tmpnam here, which is not
694 -- reliable since __gnat_tmp_name does not always use tmpnam.
696 Namestr
: aliased String (1 .. Namelen
+ 1);
697 -- Name as given or temporary file name with ASCII.NUL appended
699 Fullname
: aliased String (1 .. max_path_len
+ 1);
700 -- Full name (as required for Name function, and as stored in the
701 -- control block in the Name field) with ASCII.NUL appended.
703 Full_Name_Len
: Integer;
704 -- Length of name actually stored in Fullname
707 if File_Ptr
/= null then
711 -- Acquire form string, setting required NUL terminator
713 Formstr
(1 .. Form
'Length) := Form
;
714 Formstr
(Formstr
'Last) := ASCII
.NUL
;
716 -- Convert form string to lower case
718 for J
in Formstr
'Range loop
719 if Formstr
(J
) in 'A' .. 'Z' then
720 Formstr
(J
) := Character'Val (Character'Pos (Formstr
(J
)) + 32);
724 -- Acquire setting of shared parameter
730 Form_Parameter
(Formstr
, "shared", V1
, V2
);
735 elsif Formstr
(V1
.. V2
) = "yes" then
738 elsif Formstr
(V1
.. V2
) = "no" then
746 -- If we were given a stream (call from xxx.C_Streams.Open), then set
747 -- full name to null and that is all we have to do in this case so
748 -- skip to end of processing.
750 if Stream
/= NULL_Stream
then
751 Fullname
(1) := ASCII
.Nul
;
754 -- Normal case of Open or Create
757 -- If temporary file case, get temporary file name and add
758 -- to the list of temporary files to be deleted on exit.
765 Tmp_Name
(Namestr
'Address);
767 if Namestr
(1) = ASCII
.NUL
then
771 -- Chain to temp file list, ensuring thread safety with a lock
776 new Temp_File_Record
'(Name => Namestr, Next => Temp_Files);
785 -- Normal case of non-null name given
788 Namestr (1 .. Name'Length) := Name;
789 Namestr (Name'Length + 1) := ASCII.NUL;
792 -- Get full name in accordance with the advice of RM A.8.2(22).
794 full_name (Namestr'Address, Fullname'Address);
796 if Fullname (1) = ASCII.NUL then
801 while Full_Name_Len < Fullname'Last
802 and then Fullname (Full_Name_Len) /= ASCII.NUL
804 Full_Name_Len := Full_Name_Len + 1;
807 -- If Shared=None or Shared=Yes, then check for the existence
808 -- of another file with exactly the same full name.
817 if Fullname (1 .. Full_Name_Len) = P.Name.all then
819 -- If we get a match, and either file has Shared=None,
820 -- then raise Use_Error, since we don't allow two
821 -- files of the same name to be opened unless they
822 -- specify the required sharing mode.
825 or else P.Shared_Status = None
829 -- If both files have Shared=Yes, then we acquire the
830 -- stream from the located file to use as our stream.
833 and then P.Shared_Status = Yes
838 -- Otherwise one of the files has Shared=Yes and one
839 -- has Shared=No. If the current file has Shared=No
840 -- then all is well but we don't want to share any
841 -- other file's stream. If the current file has
842 -- Shared=Yes, we would like to share a stream, but
843 -- not from a file that has Shared=No, so in either
844 -- case we just keep going on the search.
856 -- Open specified file if we did not find an existing stream
858 if Stream = NULL_Stream then
859 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
861 -- A special case, if we are opening (OPEN case) a file and
862 -- the mode returned by Fopen_Mode is not "r" or "r+", then
863 -- we first make sure that the file exists as required by
866 if Creat = False and then Fopstr (1) /= 'r
' then
867 if file_exists (Namestr'Address) = 0 then
872 -- Now open the file. Note that we use the name as given
873 -- in the original Open call for this purpose, since that
874 -- seems the clearest implementation of the intent. It
875 -- would presumably work to use the full name here, but
876 -- if there is any difference, then we should use the
877 -- name used in the call.
879 -- Note: for a corresponding delete, we will use the
880 -- full name, since by the time of the delete, the
881 -- current working directory may have changed and
882 -- we do not want to delete a different file!
884 Stream := fopen (Namestr'Address, Fopstr'Address);
886 if Stream = NULL_Stream then
887 if file_exists (Namestr'Address) = 0 then
896 -- Stream has been successfully located or opened, so now we are
897 -- committed to completing the opening of the file. Allocate block
898 -- on heap and fill in its fields.
900 File_Ptr := AFCB_Allocate (Dummy_FCB);
902 File_Ptr.Is_Regular_File := (is_regular_file
903 (fileno (Stream)) /= 0);
904 File_Ptr.Is_System_File := False;
905 File_Ptr.Is_Text_File := Text;
906 File_Ptr.Shared_Status := Shared;
907 File_Ptr.Access_Method := Amethod;
908 File_Ptr.Stream := Stream;
909 File_Ptr.Form := new String'(Formstr
);
910 File_Ptr
.Name
:= new String'(Fullname
911 (1 .. Full_Name_Len));
912 File_Ptr.Mode := Mode;
913 File_Ptr.Is_Temporary_File := Tempfile;
915 Chain_File (File_Ptr);
916 Append_Set (File_Ptr);
923 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
927 Nread := fread (Buf, 1, Siz, File.Stream);
932 elsif ferror (File.Stream) /= 0 then
938 else -- 0 < Nread < Siz
947 Siz : in Interfaces.C_Streams.size_t;
948 Count : out Interfaces.C_Streams.size_t)
951 Count := fread (Buf, 1, Siz, File.Stream);
953 if Count = 0 and then ferror (File.Stream) /= 0 then
962 -- The reset which does not change the mode simply does a rewind.
964 procedure Reset (File : in out AFCB_Ptr) is
966 Check_File_Open (File);
967 Reset (File, File.Mode);
970 -- The reset with a change in mode is done using freopen, and is
971 -- not permitted except for regular files (since otherwise there
972 -- is no name for the freopen, and in any case it seems meaningless)
974 procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is
975 Fopstr : aliased Fopen_String;
978 Check_File_Open (File);
980 -- Change of mode not allowed for shared file or file with no name
981 -- or file that is not a regular file, or for a system file.
983 if File.Shared_Status = Yes
984 or else File.Name'Length <= 1
985 or else File.Is_System_File
986 or else (not File.Is_Regular_File)
990 -- For In_File or Inout_File for a regular file, we can just do a
991 -- rewind if the mode is unchanged, which is more efficient than
992 -- doing a full reopen.
994 elsif Mode = File.Mode
995 and then Mode <= Inout_File
997 rewind (File.Stream);
999 -- Here the change of mode is permitted, we do it by reopening the
1000 -- file in the new mode and replacing the stream with a new stream.
1004 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1007 freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
1009 if File.Stream = NULL_Stream then
1024 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1026 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1027 -- call could be reversed, but on VMS, this is a better choice, since
1028 -- for some file formats, reversing the parameters results in records
1029 -- of one byte each.
1031 SSL.Abort_Defer.all;
1033 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1035 SSL.Abort_Undefer.all;
1040 SSL.Abort_Undefer.all;