1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2009, 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 3, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Finalization; use Ada.Finalization;
33 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
35 with Interfaces.C_Streams; use Interfaces.C_Streams;
38 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 Interfaces.C.int;
51 use type System.CRTL.size_t;
53 ----------------------
54 -- Global Variables --
55 ----------------------
57 Open_Files : AFCB_Ptr;
58 -- This points to a list of AFCB's for all open files. This is a doubly
59 -- linked list, with the Prev pointer of the first entry, and the Next
60 -- pointer of the last entry containing null. Note that this global
61 -- variable must be properly protected to provide thread safety.
63 type Temp_File_Record;
64 type Temp_File_Record_Ptr is access all Temp_File_Record;
66 type Temp_File_Record is record
67 Name : String (1 .. max_path_len + 1);
68 Next : Temp_File_Record_Ptr;
70 -- One of these is allocated for each temporary file created
72 Temp_Files : Temp_File_Record_Ptr;
73 -- Points to list of names of temporary files. Note that this global
74 -- variable must be properly protected to provide thread safety.
76 type File_IO_Clean_Up_Type is new Limited_Controlled with null record;
77 -- The closing of all open files and deletion of temporary files is an
78 -- action that takes place at the end of execution of the main program.
79 -- This action is implemented using a library level object which gets
80 -- finalized at the end of program execution. Note that the type is
81 -- limited, in order to stop the compiler optimizing away the declaration
82 -- which would be allowed in the non-limited case.
84 procedure Finalize (V : in out File_IO_Clean_Up_Type);
85 -- This is the finalize operation that is used to do the cleanup
87 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
88 pragma Warnings (Off, File_IO_Clean_Up_Object);
89 -- This is the single object of the type that triggers the finalization
90 -- call. Since it is at the library level, this happens just before the
91 -- environment task is finalized.
93 text_translation_required : Boolean;
94 for text_translation_required'Size use Character'Size;
96 (C, text_translation_required, "__gnat_text_translation_required");
97 -- If true, add appropriate suffix to control string for Open
99 function Get_Case_Sensitive return Integer;
100 pragma Import (C, Get_Case_Sensitive,
101 "__gnat_get_file_names_case_sensitive");
102 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
103 -- Set to indicate whether the operating system convention is for file
104 -- names to be case sensitive (e.g., in Unix, set True), or non case
105 -- sensitive (e.g., in OS/2, set False).
107 -----------------------
108 -- Local Subprograms --
109 -----------------------
111 procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
113 subtype Fopen_String is String (1 .. 4);
114 -- Holds open string (longest is "w+b" & nul)
121 Fopstr : out Fopen_String);
122 -- Determines proper open mode for a file to be opened in the given
123 -- Ada mode. Text is true for a text file and false otherwise, and
124 -- Creat is true for a create call, and False for an open call. The
125 -- value stored in Fopstr is a nul-terminated string suitable for a
126 -- call to fopen or freopen. Amethod is the character designating
127 -- the access method from the Access_Method field of the FCB.
133 procedure Append_Set (File : AFCB_Ptr) is
135 if File.Mode = Append_File then
136 if fseek (File.Stream, 0, SEEK_END) /= 0 then
146 procedure Chain_File (File : AFCB_Ptr) is
148 -- Take a task lock, to protect the global data value Open_Files
152 -- Do the chaining operation locked
154 File.Next := Open_Files;
158 if File.Next /= null then
159 File.Next.Prev := File;
170 ---------------------
171 -- Check_File_Open --
172 ---------------------
174 procedure Check_File_Open (File : AFCB_Ptr) is
181 -----------------------
182 -- Check_Read_Status --
183 -----------------------
185 procedure Check_Read_Status (File : AFCB_Ptr) is
189 elsif File.Mode > Inout_File then
192 end Check_Read_Status;
194 ------------------------
195 -- Check_Write_Status --
196 ------------------------
198 procedure Check_Write_Status (File : AFCB_Ptr) is
202 elsif File.Mode = In_File then
205 end Check_Write_Status;
211 procedure Close (File_Ptr : access AFCB_Ptr) is
212 Close_Status : int := 0;
213 Dup_Strm : Boolean := False;
214 File : AFCB_Ptr renames File_Ptr.all;
217 -- Take a task lock, to protect the global data value Open_Files
221 Check_File_Open (File);
224 -- Sever the association between the given file and its associated
225 -- external file. The given file is left closed. Do not perform system
226 -- closes on the standard input, output and error files and also do
227 -- not attempt to close a stream that does not exist (signalled by a
228 -- null stream value -- happens in some error situations).
230 if not File.Is_System_File
231 and then File.Stream /= NULL_Stream
233 -- Do not do an fclose if this is a shared file and there is
234 -- at least one other instance of the stream that is open.
236 if File.Shared_Status = Yes then
244 and then File.Stream = P.Stream
255 -- Do the fclose unless this was a duplicate in the shared case
258 Close_Status := fclose (File.Stream);
262 -- Dechain file from list of open files and then free the storage
264 if File.Prev = null then
265 Open_Files := File.Next;
267 File.Prev.Next := File.Next;
270 if File.Next /= null then
271 File.Next.Prev := File.Prev;
274 -- Deallocate some parts of the file structure that were kept in heap
275 -- storage with the exception of system files (standard input, output
276 -- and error) since they had some information allocated in the stack.
278 if not File.Is_System_File then
279 Free_String (File.Name);
280 Free_String (File.Form);
286 if Close_Status /= 0 then
302 procedure Delete (File_Ptr : access AFCB_Ptr) is
303 File : AFCB_Ptr renames File_Ptr.all;
305 Check_File_Open (File);
307 if not File.Is_Regular_File then
312 Filename : aliased constant String := File.Name.all;
317 -- Now unlink the external file. Note that we use the full name
318 -- in this unlink, because the working directory may have changed
319 -- since we did the open, and we want to unlink the right file!
321 if unlink (Filename'Address) = -1 then
331 function End_Of_File (File : AFCB_Ptr) return Boolean is
333 Check_File_Open (File);
335 if feof (File.Stream) /= 0 then
339 Check_Read_Status (File);
341 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
342 clearerr (File.Stream);
354 -- Note: we do not need to worry about locking against multiple task
355 -- access in this routine, since it is called only from the environment
356 -- task just before terminating execution.
358 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
359 pragma Warnings (Off, V);
361 Fptr1 : aliased AFCB_Ptr;
365 pragma Unreferenced (Discard);
368 -- Take a lock to protect global Open_Files data structure
372 -- First close all open files (the slightly complex form of this loop
373 -- is required because Close as a side effect nulls out its argument)
376 while Fptr1 /= null loop
378 Close (Fptr1'Access);
382 -- Now unlink all temporary files. We do not bother to free the
383 -- blocks because we are just about to terminate the program. We
384 -- also ignore any errors while attempting these unlink operations.
386 while Temp_Files /= null loop
387 Discard := unlink (Temp_Files.Name'Address);
388 Temp_Files := Temp_Files.Next;
403 procedure Flush (File : AFCB_Ptr) is
405 Check_Write_Status (File);
407 if fflush (File.Stream) = 0 then
418 -- The fopen mode to be used is shown by the following table:
421 -- Append_File "r+" "w+"
423 -- Out_File (Direct_IO) "r+" "w"
424 -- Out_File (all others) "w" "w"
425 -- Inout_File "r+" "w+"
427 -- Note: we do not use "a" or "a+" for Append_File, since this would not
428 -- work in the case of stream files, where even if in append file mode,
429 -- you can reset to earlier points in the file. The caller must use the
430 -- Append_Set routine to deal with the necessary positioning.
432 -- Note: in several cases, the fopen mode used allows reading and
433 -- writing, but the setting of the Ada mode is more restrictive. For
434 -- instance, Create in In_File mode uses "w+" which allows writing,
435 -- but the Ada mode In_File will cause any write operations to be
436 -- rejected with Mode_Error in any case.
438 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
439 -- an initial call will be made by the caller to first open the file in
440 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
441 -- then destroy this file. This is peculiar, but that's what Ada semantics
442 -- require and the ACVT tests insist on!
444 -- If text file translation is required, then either b or t is
445 -- added to the mode, depending on the setting of Text.
452 Fopstr : out Fopen_String)
469 if Amethod = 'D' and then not Creat then
478 when Inout_File | Append_File =>
490 -- If text_translation_required is true then we need to append
491 -- either a t or b to the string to get the right mode
493 if text_translation_required then
495 Fopstr (Fptr) := 't';
497 Fopstr (Fptr) := 'b';
503 Fopstr (Fptr) := ASCII.NUL;
510 function Form (File : AFCB_Ptr) return String is
515 return File.Form.all (1 .. File.Form'Length - 1);
523 function Form_Boolean
530 pragma Unreferenced (V2);
533 Form_Parameter (Form, Keyword, V1, V2);
538 elsif Form (V1) = 'y' then
541 elsif Form (V1) = 'n' then
553 function Form_Integer
563 Form_Parameter (Form, Keyword, V1, V2);
571 for J in V1 .. V2 loop
572 if Form (J) not in '0' .. '9' then
575 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
591 procedure Form_Parameter
597 Klen : constant Integer := Keyword'Length;
599 -- Start of processing for Form_Parameter
602 for J in Form'First + Klen .. Form'Last - 1 loop
604 and then Form (J - Klen .. J - 1) = Keyword
609 while Form (Stop + 1) /= ASCII.NUL
610 and then Form (Stop + 1) /= ','
627 function Is_Open (File : AFCB_Ptr) return Boolean is
629 -- We return True if the file is open, and the underlying file stream is
630 -- usable. In particular on Windows an application linked with -mwindows
631 -- option set does not have a console attached. In this case standard
632 -- files (Current_Output, Current_Error, Current_Input) are not created.
633 -- We want Is_Open (Current_Output) to return False in this case.
635 return File /= null and then fileno (File.Stream) /= -1;
642 procedure Make_Buffered
644 Buf_Siz : Interfaces.C_Streams.size_t)
647 pragma Unreferenced (status);
650 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
653 ------------------------
654 -- Make_Line_Buffered --
655 ------------------------
657 procedure Make_Line_Buffered
659 Line_Siz : Interfaces.C_Streams.size_t)
662 pragma Unreferenced (status);
665 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
666 end Make_Line_Buffered;
668 ---------------------
669 -- Make_Unbuffered --
670 ---------------------
672 procedure Make_Unbuffered (File : AFCB_Ptr) is
674 pragma Unreferenced (status);
677 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
684 function Mode (File : AFCB_Ptr) return File_Mode is
697 function Name (File : AFCB_Ptr) return String is
702 return File.Name.all (1 .. File.Name'Length - 1);
711 (File_Ptr : in out AFCB_Ptr;
712 Dummy_FCB : AFCB'Class;
719 C_Stream : FILEs := NULL_Stream)
721 pragma Warnings (Off, Dummy_FCB);
722 -- Yes we know this is never assigned a value. That's intended, since
723 -- all we ever use of this value is the tag for dispatching purposes.
725 procedure Tmp_Name (Buffer : Address);
726 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
727 -- set buffer (a String address) with a temporary filename
729 Stream : FILEs := C_Stream;
730 -- Stream which we open in response to this request
732 Shared : Shared_Status_Type;
733 -- Setting of Shared_Status field for file
735 Fopstr : aliased Fopen_String;
736 -- Mode string used in fopen call
738 Formstr : aliased String (1 .. Form'Length + 1);
739 -- Form string with ASCII.NUL appended, folded to lower case
741 Is_Text_File : Boolean;
743 Tempfile : constant Boolean := (Name'Length = 0);
744 -- Indicates temporary file case
746 Namelen : constant Integer := max_path_len;
747 -- Length required for file name, not including final ASCII.NUL
748 -- Note that we used to reference L_tmpnam here, which is not
749 -- reliable since __gnat_tmp_name does not always use tmpnam.
751 Namestr : aliased String (1 .. Namelen + 1);
752 -- Name as given or temporary file name with ASCII.NUL appended
754 Fullname : aliased String (1 .. max_path_len + 1);
755 -- Full name (as required for Name function, and as stored in the
756 -- control block in the Name field) with ASCII.NUL appended.
758 Full_Name_Len : Integer;
759 -- Length of name actually stored in Fullname
761 Encoding : System.CRTL.Filename_Encoding;
762 -- Filename encoding specified into the form parameter
765 if File_Ptr /= null then
769 -- Acquire form string, setting required NUL terminator
771 Formstr (1 .. Form'Length) := Form;
772 Formstr (Formstr'Last) := ASCII.NUL;
774 -- Convert form string to lower case
776 for J in Formstr'Range loop
777 if Formstr (J) in 'A' .. 'Z' then
778 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
782 -- Acquire setting of shared parameter
788 Form_Parameter (Formstr, "shared", V1, V2);
793 elsif Formstr (V1 .. V2) = "yes" then
796 elsif Formstr (V1 .. V2) = "no" then
804 -- Acquire setting of encoding parameter
810 Form_Parameter (Formstr, "encoding", V1, V2);
813 Encoding := System.CRTL.Unspecified;
815 elsif Formstr (V1 .. V2) = "utf8" then
816 Encoding := System.CRTL.UTF8;
818 elsif Formstr (V1 .. V2) = "8bits" then
819 Encoding := System.CRTL.ASCII_8bits;
826 -- Acquire setting of text_translation parameter. Only needed if this is
827 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
828 -- if the Form says Text_Translation=No, we use binary mode, so new-line
829 -- will be just LF, even on Windows.
831 Is_Text_File := Text;
835 Form_Boolean (Formstr, "text_translation", Default => True);
838 -- If we were given a stream (call from xxx.C_Streams.Open), then set
839 -- the full name to the given one, and skip to end of processing.
841 if Stream /= NULL_Stream then
842 Full_Name_Len := Name'Length + 1;
843 Fullname (1 .. Full_Name_Len - 1) := Name;
844 Fullname (Full_Name_Len) := ASCII.NUL;
846 -- Normal case of Open or Create
849 -- If temporary file case, get temporary file name and add to the
850 -- list of temporary files to be deleted on exit.
857 Tmp_Name (Namestr'Address);
859 if Namestr (1) = ASCII.NUL then
863 -- Chain to temp file list, ensuring thread safety with a lock
868 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
877 -- Normal case of non-null name given
880 if Name'Length > Namelen then
884 Namestr (1 .. Name'Length) := Name;
885 Namestr (Name'Length + 1) := ASCII.NUL;
888 -- Get full name in accordance with the advice of RM A.8.2(22)
890 full_name (Namestr'Address, Fullname'Address);
892 if Fullname (1) = ASCII.NUL then
897 while Full_Name_Len < Fullname'Last
898 and then Fullname (Full_Name_Len) /= ASCII.NUL
900 Full_Name_Len := Full_Name_Len + 1;
903 -- Fullname is generated by calling system's full_name. The problem
904 -- is, full_name does nothing about the casing, so a file name
905 -- comparison may generally speaking not be valid on non-case
906 -- sensitive systems, and in particular we get unexpected failures
907 -- on Windows/Vista because of this. So we use s-casuti to force
908 -- the name to lower case.
910 if not File_Names_Case_Sensitive then
911 To_Lower (Fullname (1 .. Full_Name_Len));
914 -- If Shared=None or Shared=Yes, then check for the existence
915 -- of another file with exactly the same full name.
922 -- Take a task lock to protect Open_Files
926 -- Search list of open files
930 if Fullname (1 .. Full_Name_Len) = P.Name.all then
932 -- If we get a match, and either file has Shared=None,
933 -- then raise Use_Error, since we don't allow two files
934 -- of the same name to be opened unless they specify the
935 -- required sharing mode.
938 or else P.Shared_Status = None
942 -- If both files have Shared=Yes, then we acquire the
943 -- stream from the located file to use as our stream.
946 and then P.Shared_Status = Yes
951 -- Otherwise one of the files has Shared=Yes and one has
952 -- Shared=No. If the current file has Shared=No then all
953 -- is well but we don't want to share any other file's
954 -- stream. If the current file has Shared=Yes, we would
955 -- like to share a stream, but not from a file that has
956 -- Shared=No, so either way, we just continue the search.
975 -- Open specified file if we did not find an existing stream
977 if Stream = NULL_Stream then
978 Fopen_Mode (Mode, Is_Text_File, Creat, Amethod, Fopstr);
980 -- A special case, if we are opening (OPEN case) a file and the
981 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
982 -- make sure that the file exists as required by Ada semantics.
984 if not Creat and then Fopstr (1) /= 'r' then
985 if file_exists (Namestr'Address) = 0 then
990 -- Now open the file. Note that we use the name as given in the
991 -- original Open call for this purpose, since that seems the
992 -- clearest implementation of the intent. It would presumably
993 -- work to use the full name here, but if there is any difference,
994 -- then we should use the name used in the call.
996 -- Note: for a corresponding delete, we will use the full name,
997 -- since by the time of the delete, the current working directory
998 -- may have changed and we do not want to delete a different file!
1000 Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
1002 if Stream = NULL_Stream then
1004 -- Raise Name_Error if trying to open a non-existent file.
1005 -- Otherwise raise Use_Error.
1007 -- Should we raise Device_Error for ENOSPC???
1010 subtype Cint is Interfaces.C.int;
1012 function Is_File_Not_Found_Error
1013 (Errno_Value : Cint) return Cint;
1014 -- Non-zero when the given errno value indicates a non-
1018 (C, Is_File_Not_Found_Error,
1019 "__gnat_is_file_not_found_error");
1023 Is_File_Not_Found_Error (Cint (System.OS_Lib.Errno)) /= 0
1034 -- Stream has been successfully located or opened, so now we are
1035 -- committed to completing the opening of the file. Allocate block
1036 -- on heap and fill in its fields.
1038 File_Ptr := AFCB_Allocate (Dummy_FCB);
1040 File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0);
1041 File_Ptr.Is_System_File := False;
1042 File_Ptr.Is_Text_File := Is_Text_File;
1043 File_Ptr.Shared_Status := Shared;
1044 File_Ptr.Access_Method := Amethod;
1045 File_Ptr.Stream := Stream;
1046 File_Ptr.Form := new String'(Formstr);
1047 File_Ptr.Name := new String'(Fullname (1 .. Full_Name_Len));
1048 File_Ptr.Mode := Mode;
1049 File_Ptr.Is_Temporary_File := Tempfile;
1050 File_Ptr.Encoding := Encoding;
1052 Chain_File (File_Ptr);
1053 Append_Set (File_Ptr);
1060 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1064 Nread := fread (Buf, 1, Siz, File.Stream);
1069 elsif ferror (File.Stream) /= 0 then
1072 elsif Nread = 0 then
1075 else -- 0 < Nread < Siz
1084 Siz : Interfaces.C_Streams.size_t;
1085 Count : out Interfaces.C_Streams.size_t)
1088 Count := fread (Buf, 1, Siz, File.Stream);
1090 if Count = 0 and then ferror (File.Stream) /= 0 then
1099 -- The reset which does not change the mode simply does a rewind
1101 procedure Reset (File_Ptr : access AFCB_Ptr) is
1102 File : AFCB_Ptr renames File_Ptr.all;
1104 Check_File_Open (File);
1105 Reset (File_Ptr, File.Mode);
1108 -- The reset with a change in mode is done using freopen, and is
1109 -- not permitted except for regular files (since otherwise there
1110 -- is no name for the freopen, and in any case it seems meaningless)
1112 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
1113 File : AFCB_Ptr renames File_Ptr.all;
1114 Fopstr : aliased Fopen_String;
1117 Check_File_Open (File);
1119 -- Change of mode not allowed for shared file or file with no name or
1120 -- file that is not a regular file, or for a system file. Note that we
1121 -- allow the "change" of mode if it is not in fact doing a change.
1123 if Mode /= File.Mode
1124 and then (File.Shared_Status = Yes
1125 or else File.Name'Length <= 1
1126 or else File.Is_System_File
1127 or else not File.Is_Regular_File)
1131 -- For In_File or Inout_File for a regular file, we can just do a
1132 -- rewind if the mode is unchanged, which is more efficient than
1133 -- doing a full reopen.
1135 elsif Mode = File.Mode
1136 and then Mode <= Inout_File
1138 rewind (File.Stream);
1140 -- Here the change of mode is permitted, we do it by reopening the
1141 -- file in the new mode and replacing the stream with a new stream.
1145 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1147 File.Stream := freopen
1148 (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
1150 if File.Stream = NULL_Stream then
1165 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1167 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1168 -- call could be reversed, but on VMS, this is a better choice, since
1169 -- for some file formats, reversing the parameters results in records
1170 -- of one byte each.
1172 SSL.Abort_Defer.all;
1174 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1176 SSL.Abort_Undefer.all;
1181 SSL.Abort_Undefer.all;