1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2008, 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;
37 with Interfaces.C_Streams; use Interfaces.C_Streams;
40 with System.Case_Util; use System.Case_Util;
42 with System.Soft_Links;
44 with Ada.Unchecked_Deallocation;
46 package body System.File_IO is
48 use System.File_Control_Block;
50 package SSL renames System.Soft_Links;
52 use type Interfaces.C.int;
53 use type System.CRTL.size_t;
55 ----------------------
56 -- Global Variables --
57 ----------------------
59 Open_Files : AFCB_Ptr;
60 -- This points to a list of AFCB's for all open files. This is a doubly
61 -- linked list, with the Prev pointer of the first entry, and the Next
62 -- pointer of the last entry containing null. Note that this global
63 -- variable must be properly protected to provide thread safety.
65 type Temp_File_Record;
66 type Temp_File_Record_Ptr is access all Temp_File_Record;
68 type Temp_File_Record is record
69 Name : String (1 .. max_path_len + 1);
70 Next : Temp_File_Record_Ptr;
72 -- One of these is allocated for each temporary file created
74 Temp_Files : Temp_File_Record_Ptr;
75 -- Points to list of names of temporary files. Note that this global
76 -- variable must be properly protected to provide thread safety.
78 type File_IO_Clean_Up_Type is new Controlled with null record;
79 -- The closing of all open files and deletion of temporary files is an
80 -- action which takes place at the end of execution of the main program.
81 -- This action can be implemented using a library level object which
82 -- gets finalized at the end of the main program execution. The above is
83 -- a controlled type introduced for this purpose.
85 procedure Finalize (V : in out File_IO_Clean_Up_Type);
86 -- This is the finalize operation that is used to do the cleanup
88 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
89 pragma Warnings (Off, File_IO_Clean_Up_Object);
90 -- This is the single object of the type that triggers the finalization
91 -- call. Since it is at the library level, this happens just before the
92 -- environment task is finalized.
94 text_translation_required : Boolean;
95 for text_translation_required'Size use Character'Size;
97 (C, text_translation_required, "__gnat_text_translation_required");
98 -- If true, add appropriate suffix to control string for Open
100 function Get_Case_Sensitive return Integer;
101 pragma Import (C, Get_Case_Sensitive,
102 "__gnat_get_file_names_case_sensitive");
103 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
104 -- Set to indicate whether the operating system convention is for file
105 -- names to be case sensitive (e.g., in Unix, set True), or non case
106 -- sensitive (e.g., in OS/2, set False).
108 -----------------------
109 -- Local Subprograms --
110 -----------------------
112 procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
114 subtype Fopen_String is String (1 .. 4);
115 -- Holds open string (longest is "w+b" & nul)
122 Fopstr : out Fopen_String);
123 -- Determines proper open mode for a file to be opened in the given
124 -- Ada mode. Text is true for a text file and false otherwise, and
125 -- Creat is true for a create call, and False for an open call. The
126 -- value stored in Fopstr is a nul-terminated string suitable for a
127 -- call to fopen or freopen. Amethod is the character designating
128 -- the access method from the Access_Method field of the FCB.
134 procedure Append_Set (File : AFCB_Ptr) is
136 if File.Mode = Append_File then
137 if fseek (File.Stream, 0, SEEK_END) /= 0 then
147 procedure Chain_File (File : AFCB_Ptr) is
149 -- Take a task lock, to protect the global data value Open_Files
153 -- Do the chaining operation locked
155 File.Next := Open_Files;
159 if File.Next /= null then
160 File.Next.Prev := File;
171 ---------------------
172 -- Check_File_Open --
173 ---------------------
175 procedure Check_File_Open (File : AFCB_Ptr) is
182 -----------------------
183 -- Check_Read_Status --
184 -----------------------
186 procedure Check_Read_Status (File : AFCB_Ptr) is
190 elsif File.Mode > Inout_File then
193 end Check_Read_Status;
195 ------------------------
196 -- Check_Write_Status --
197 ------------------------
199 procedure Check_Write_Status (File : AFCB_Ptr) is
203 elsif File.Mode = In_File then
206 end Check_Write_Status;
212 procedure Close (File_Ptr : access AFCB_Ptr) is
213 Close_Status : int := 0;
214 Dup_Strm : Boolean := False;
215 File : AFCB_Ptr renames File_Ptr.all;
218 -- Take a task lock, to protect the global data value Open_Files
222 Check_File_Open (File);
225 -- Sever the association between the given file and its associated
226 -- external file. The given file is left closed. Do not perform system
227 -- closes on the standard input, output and error files and also do
228 -- not attempt to close a stream that does not exist (signalled by a
229 -- null stream value -- happens in some error situations).
231 if not File.Is_System_File
232 and then File.Stream /= NULL_Stream
234 -- Do not do an fclose if this is a shared file and there is
235 -- at least one other instance of the stream that is open.
237 if File.Shared_Status = Yes then
245 and then File.Stream = P.Stream
256 -- Do the fclose unless this was a duplicate in the shared case
259 Close_Status := fclose (File.Stream);
263 -- Dechain file from list of open files and then free the storage
265 if File.Prev = null then
266 Open_Files := File.Next;
268 File.Prev.Next := File.Next;
271 if File.Next /= null then
272 File.Next.Prev := File.Prev;
275 -- Deallocate some parts of the file structure that were kept in heap
276 -- storage with the exception of system files (standard input, output
277 -- and error) since they had some information allocated in the stack.
279 if not File.Is_System_File then
280 Free_String (File.Name);
281 Free_String (File.Form);
287 if Close_Status /= 0 then
303 procedure Delete (File_Ptr : access AFCB_Ptr) is
304 File : AFCB_Ptr renames File_Ptr.all;
306 Check_File_Open (File);
308 if not File.Is_Regular_File then
313 Filename : aliased constant String := File.Name.all;
318 -- Now unlink the external file. Note that we use the full name
319 -- in this unlink, because the working directory may have changed
320 -- since we did the open, and we want to unlink the right file!
322 if unlink (Filename'Address) = -1 then
332 function End_Of_File (File : AFCB_Ptr) return Boolean is
334 Check_File_Open (File);
336 if feof (File.Stream) /= 0 then
340 Check_Read_Status (File);
342 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
343 clearerr (File.Stream);
355 -- Note: we do not need to worry about locking against multiple task
356 -- access in this routine, since it is called only from the environment
357 -- task just before terminating execution.
359 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
360 pragma Warnings (Off, V);
362 Fptr1 : aliased AFCB_Ptr;
366 pragma Unreferenced (Discard);
369 -- Take a lock to protect global Open_Files data structure
373 -- First close all open files (the slightly complex form of this loop
374 -- is required because Close as a side effect nulls out its argument)
377 while Fptr1 /= null loop
379 Close (Fptr1'Access);
383 -- Now unlink all temporary files. We do not bother to free the
384 -- blocks because we are just about to terminate the program. We
385 -- also ignore any errors while attempting these unlink operations.
387 while Temp_Files /= null loop
388 Discard := unlink (Temp_Files.Name'Address);
389 Temp_Files := Temp_Files.Next;
404 procedure Flush (File : AFCB_Ptr) is
406 Check_Write_Status (File);
408 if fflush (File.Stream) = 0 then
419 -- The fopen mode to be used is shown by the following table:
422 -- Append_File "r+" "w+"
424 -- Out_File (Direct_IO) "r+" "w"
425 -- Out_File (all others) "w" "w"
426 -- Inout_File "r+" "w+"
428 -- Note: we do not use "a" or "a+" for Append_File, since this would not
429 -- work in the case of stream files, where even if in append file mode,
430 -- you can reset to earlier points in the file. The caller must use the
431 -- Append_Set routine to deal with the necessary positioning.
433 -- Note: in several cases, the fopen mode used allows reading and
434 -- writing, but the setting of the Ada mode is more restrictive. For
435 -- instance, Create in In_File mode uses "w+" which allows writing,
436 -- but the Ada mode In_File will cause any write operations to be
437 -- rejected with Mode_Error in any case.
439 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
440 -- an initial call will be made by the caller to first open the file in
441 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
442 -- then destroy this file. This is peculiar, but that's what Ada semantics
443 -- require and the ACVT tests insist on!
445 -- If text file translation is required, then either b or t is
446 -- added to the mode, depending on the setting of Text.
453 Fopstr : out Fopen_String)
470 if Amethod = 'D' and not Creat then
479 when Inout_File | Append_File =>
491 -- If text_translation_required is true then we need to append
492 -- either a t or b to the string to get the right mode
494 if text_translation_required then
496 Fopstr (Fptr) := 't';
498 Fopstr (Fptr) := 'b';
504 Fopstr (Fptr) := ASCII.NUL;
511 function Form (File : AFCB_Ptr) return String is
516 return File.Form.all (1 .. File.Form'Length - 1);
524 function Form_Boolean
531 pragma Unreferenced (V2);
534 Form_Parameter (Form, Keyword, V1, V2);
539 elsif Form (V1) = 'y' then
542 elsif Form (V1) = 'n' then
554 function Form_Integer
564 Form_Parameter (Form, Keyword, V1, V2);
572 for J in V1 .. V2 loop
573 if Form (J) not in '0' .. '9' then
576 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
592 procedure Form_Parameter
598 Klen : constant Integer := Keyword'Length;
600 -- Start of processing for Form_Parameter
603 for J in Form'First + Klen .. Form'Last - 1 loop
605 and then Form (J - Klen .. J - 1) = Keyword
610 while Form (Stop + 1) /= ASCII.NUL
611 and then Form (Stop + 1) /= ','
628 function Is_Open (File : AFCB_Ptr) return Boolean is
630 -- We return True if the file is open, and the underlying file stream is
631 -- usable. In particular on Windows an application linked with -mwindows
632 -- option set does not have a console attached. In this case standard
633 -- files (Current_Output, Current_Error, Current_Input) are not created.
634 -- We want Is_Open (Current_Output) to return False in this case.
636 return File /= null and then fileno (File.Stream) /= -1;
643 procedure Make_Buffered
645 Buf_Siz : Interfaces.C_Streams.size_t)
648 pragma Unreferenced (status);
651 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
654 ------------------------
655 -- Make_Line_Buffered --
656 ------------------------
658 procedure Make_Line_Buffered
660 Line_Siz : Interfaces.C_Streams.size_t)
663 pragma Unreferenced (status);
666 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
667 end Make_Line_Buffered;
669 ---------------------
670 -- Make_Unbuffered --
671 ---------------------
673 procedure Make_Unbuffered (File : AFCB_Ptr) is
675 pragma Unreferenced (status);
678 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
685 function Mode (File : AFCB_Ptr) return File_Mode is
698 function Name (File : AFCB_Ptr) return String is
703 return File.Name.all (1 .. File.Name'Length - 1);
712 (File_Ptr : in out AFCB_Ptr;
713 Dummy_FCB : AFCB'Class;
720 C_Stream : FILEs := NULL_Stream)
722 pragma Warnings (Off, Dummy_FCB);
723 -- Yes we know this is never assigned a value. That's intended, since
724 -- all we ever use of this value is the tag for dispatching purposes.
726 procedure Tmp_Name (Buffer : Address);
727 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
728 -- set buffer (a String address) with a temporary filename
730 Stream : FILEs := C_Stream;
731 -- Stream which we open in response to this request
733 Shared : Shared_Status_Type;
734 -- Setting of Shared_Status field for file
736 Fopstr : aliased Fopen_String;
737 -- Mode string used in fopen call
739 Formstr : aliased String (1 .. Form'Length + 1);
740 -- Form string with ASCII.NUL appended, folded to lower case
742 Tempfile : constant Boolean := (Name'Length = 0);
743 -- Indicates temporary file case
745 Namelen : constant Integer := max_path_len;
746 -- Length required for file name, not including final ASCII.NUL
747 -- Note that we used to reference L_tmpnam here, which is not
748 -- reliable since __gnat_tmp_name does not always use tmpnam.
750 Namestr : aliased String (1 .. Namelen + 1);
751 -- Name as given or temporary file name with ASCII.NUL appended
753 Fullname : aliased String (1 .. max_path_len + 1);
754 -- Full name (as required for Name function, and as stored in the
755 -- control block in the Name field) with ASCII.NUL appended.
757 Full_Name_Len : Integer;
758 -- Length of name actually stored in Fullname
760 Encoding : System.CRTL.Filename_Encoding;
761 -- Filename encoding specified into the form parameter
764 if File_Ptr /= null then
768 -- Acquire form string, setting required NUL terminator
770 Formstr (1 .. Form'Length) := Form;
771 Formstr (Formstr'Last) := ASCII.NUL;
773 -- Convert form string to lower case
775 for J in Formstr'Range loop
776 if Formstr (J) in 'A' .. 'Z' then
777 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
781 -- Acquire setting of shared parameter
787 Form_Parameter (Formstr, "shared", V1, V2);
792 elsif Formstr (V1 .. V2) = "yes" then
795 elsif Formstr (V1 .. V2) = "no" then
803 -- Acquire setting of shared parameter
809 Form_Parameter (Formstr, "encoding", V1, V2);
812 Encoding := System.CRTL.UTF8;
814 elsif Formstr (V1 .. V2) = "utf8" then
815 Encoding := System.CRTL.UTF8;
817 elsif Formstr (V1 .. V2) = "8bits" then
818 Encoding := System.CRTL.ASCII_8bits;
825 -- If we were given a stream (call from xxx.C_Streams.Open), then set
826 -- the full name to the given one, and skip to end of processing.
828 if Stream /= NULL_Stream then
829 Full_Name_Len := Name'Length + 1;
830 Fullname (1 .. Full_Name_Len - 1) := Name;
831 Fullname (Full_Name_Len) := ASCII.NUL;
833 -- Normal case of Open or Create
836 -- If temporary file case, get temporary file name and add to the
837 -- list of temporary files to be deleted on exit.
844 Tmp_Name (Namestr'Address);
846 if Namestr (1) = ASCII.NUL then
850 -- Chain to temp file list, ensuring thread safety with a lock
855 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
864 -- Normal case of non-null name given
867 if Name'Length > Namelen then
871 Namestr (1 .. Name'Length) := Name;
872 Namestr (Name'Length + 1) := ASCII.NUL;
875 -- Get full name in accordance with the advice of RM A.8.2(22)
877 full_name (Namestr'Address, Fullname'Address);
879 if Fullname (1) = ASCII.NUL then
884 while Full_Name_Len < Fullname'Last
885 and then Fullname (Full_Name_Len) /= ASCII.NUL
887 Full_Name_Len := Full_Name_Len + 1;
890 -- Fullname is generated by calling system's full_name. The problem
891 -- is, full_name does nothing about the casing, so a file name
892 -- comparison may generally speaking not be valid on non-case
893 -- sensitive systems, and in particular we get unexpected failures
894 -- on Windows/Vista because of this. So we use s-casuti to force
895 -- the name to lower case.
897 if not File_Names_Case_Sensitive then
898 To_Lower (Fullname (1 .. Full_Name_Len));
901 -- If Shared=None or Shared=Yes, then check for the existence
902 -- of another file with exactly the same full name.
909 -- Take a task lock to protect Open_Files
913 -- Search list of open files
917 if Fullname (1 .. Full_Name_Len) = P.Name.all then
919 -- If we get a match, and either file has Shared=None,
920 -- then raise Use_Error, since we don't allow two files
921 -- of the same name to be opened unless they specify the
922 -- required sharing mode.
925 or else P.Shared_Status = None
929 -- If both files have Shared=Yes, then we acquire the
930 -- stream from the located file to use as our stream.
933 and then P.Shared_Status = Yes
938 -- Otherwise one of the files has Shared=Yes and one has
939 -- Shared=No. If the current file has Shared=No then all
940 -- is well but we don't want to share any other file's
941 -- stream. If the current file has Shared=Yes, we would
942 -- like to share a stream, but not from a file that has
943 -- Shared=No, so either way, we just continue the search.
962 -- Open specified file if we did not find an existing stream
964 if Stream = NULL_Stream then
965 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
967 -- A special case, if we are opening (OPEN case) a file and the
968 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
969 -- make sure that the file exists as required by Ada semantics.
971 if not Creat and then Fopstr (1) /= 'r' then
972 if file_exists (Namestr'Address) = 0 then
977 -- Now open the file. Note that we use the name as given in the
978 -- original Open call for this purpose, since that seems the
979 -- clearest implementation of the intent. It would presumably
980 -- work to use the full name here, but if there is any difference,
981 -- then we should use the name used in the call.
983 -- Note: for a corresponding delete, we will use the full name,
984 -- since by the time of the delete, the current working directory
985 -- may have changed and we do not want to delete a different file!
987 Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
989 if Stream = NULL_Stream then
991 -- Raise Name_Error if trying to open a non-existent file.
992 -- Otherwise raise Use_Error.
994 -- Should we raise Device_Error for ENOSPC???
997 subtype Cint is Interfaces.C.int;
999 function Is_File_Not_Found_Error
1000 (Errno_Value : Cint) return Cint;
1001 -- Non-zero when the given errno value indicates a non-
1005 (C, Is_File_Not_Found_Error,
1006 "__gnat_is_file_not_found_error");
1010 Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0
1021 -- Stream has been successfully located or opened, so now we are
1022 -- committed to completing the opening of the file. Allocate block
1023 -- on heap and fill in its fields.
1025 File_Ptr := AFCB_Allocate (Dummy_FCB);
1027 File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0);
1028 File_Ptr.Is_System_File := False;
1029 File_Ptr.Is_Text_File := Text;
1030 File_Ptr.Shared_Status := Shared;
1031 File_Ptr.Access_Method := Amethod;
1032 File_Ptr.Stream := Stream;
1033 File_Ptr.Form := new String'(Formstr);
1034 File_Ptr.Name := new String'(Fullname (1 .. Full_Name_Len));
1035 File_Ptr.Mode := Mode;
1036 File_Ptr.Is_Temporary_File := Tempfile;
1037 File_Ptr.Encoding := Encoding;
1039 Chain_File (File_Ptr);
1040 Append_Set (File_Ptr);
1047 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1051 Nread := fread (Buf, 1, Siz, File.Stream);
1056 elsif ferror (File.Stream) /= 0 then
1059 elsif Nread = 0 then
1062 else -- 0 < Nread < Siz
1071 Siz : Interfaces.C_Streams.size_t;
1072 Count : out Interfaces.C_Streams.size_t)
1075 Count := fread (Buf, 1, Siz, File.Stream);
1077 if Count = 0 and then ferror (File.Stream) /= 0 then
1086 -- The reset which does not change the mode simply does a rewind
1088 procedure Reset (File_Ptr : access AFCB_Ptr) is
1089 File : AFCB_Ptr renames File_Ptr.all;
1091 Check_File_Open (File);
1092 Reset (File_Ptr, File.Mode);
1095 -- The reset with a change in mode is done using freopen, and is
1096 -- not permitted except for regular files (since otherwise there
1097 -- is no name for the freopen, and in any case it seems meaningless)
1099 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
1100 File : AFCB_Ptr renames File_Ptr.all;
1101 Fopstr : aliased Fopen_String;
1104 Check_File_Open (File);
1106 -- Change of mode not allowed for shared file or file with no name or
1107 -- file that is not a regular file, or for a system file. Note that we
1108 -- allow the "change" of mode if it is not in fact doing a change.
1110 if Mode /= File.Mode
1111 and then (File.Shared_Status = Yes
1112 or else File.Name'Length <= 1
1113 or else File.Is_System_File
1114 or else not File.Is_Regular_File)
1118 -- For In_File or Inout_File for a regular file, we can just do a
1119 -- rewind if the mode is unchanged, which is more efficient than
1120 -- doing a full reopen.
1122 elsif Mode = File.Mode
1123 and then Mode <= Inout_File
1125 rewind (File.Stream);
1127 -- Here the change of mode is permitted, we do it by reopening the
1128 -- file in the new mode and replacing the stream with a new stream.
1132 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1134 File.Stream := freopen
1135 (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
1137 if File.Stream = NULL_Stream then
1152 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1154 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1155 -- call could be reversed, but on VMS, this is a better choice, since
1156 -- for some file formats, reversing the parameters results in records
1157 -- of one byte each.
1159 SSL.Abort_Defer.all;
1161 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1163 SSL.Abort_Undefer.all;
1168 SSL.Abort_Undefer.all;