1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2017, 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
;
34 with Ada
.Unchecked_Deallocation
;
36 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
38 with System
.Case_Util
; use System
.Case_Util
;
41 with System
.Soft_Links
;
43 package body System
.File_IO
is
45 use System
.File_Control_Block
;
47 package SSL
renames System
.Soft_Links
;
51 ----------------------
52 -- Global Variables --
53 ----------------------
55 Open_Files
: AFCB_Ptr
;
56 -- This points to a list of AFCB's for all open files. This is a doubly
57 -- linked list, with the Prev pointer of the first entry, and the Next
58 -- pointer of the last entry containing null. Note that this global
59 -- variable must be properly protected to provide thread safety.
61 type Temp_File_Record
;
62 type Temp_File_Record_Ptr
is access all Temp_File_Record
;
64 type Temp_File_Record
is record
66 Next
: aliased Temp_File_Record_Ptr
;
67 Name
: String (1 .. max_path_len
+ 1);
69 -- One of these is allocated for each temporary file created
71 Temp_Files
: aliased 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 procedure Free
is new Ada
.Unchecked_Deallocation
76 (Temp_File_Record
, Temp_File_Record_Ptr
);
78 type File_IO_Clean_Up_Type
is new Limited_Controlled
with null record;
79 -- The closing of all open files and deletion of temporary files is an
80 -- action that takes place at the end of execution of the main program.
81 -- This action is implemented using a library level object that gets
82 -- finalized at the end of program execution. Note that the type is
83 -- limited, in order to stop the compiler optimizing away the declaration
84 -- which would be allowed in the non-limited case.
86 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
);
87 -- This is the finalize operation that is used to do the cleanup
89 File_IO_Clean_Up_Object
: File_IO_Clean_Up_Type
;
90 pragma Warnings
(Off
, File_IO_Clean_Up_Object
);
91 -- This is the single object of the type that triggers the finalization
92 -- call. Since it is at the library level, this happens just before the
93 -- environment task is finalized.
95 text_translation_required
: Boolean;
96 for text_translation_required
'Size use Character'Size;
98 (C
, text_translation_required
, "__gnat_text_translation_required");
99 -- If true, add appropriate suffix to control string for Open
101 -----------------------
102 -- Local Subprograms --
103 -----------------------
105 procedure Free_String
is new Ada
.Unchecked_Deallocation
(String, Pstring
);
107 subtype Fopen_String
is String (1 .. 4);
108 -- Holds open string (longest is "w+b" & nul)
116 Fopstr
: out Fopen_String
);
117 -- Determines proper open mode for a file to be opened in the given Ada
118 -- mode. Namestr is the NUL-terminated file name. Text is true for a text
119 -- file and false otherwise, and Creat is true for a create call, and False
120 -- for an open call. The value stored in Fopstr is a nul-terminated string
121 -- suitable for a call to fopen or freopen. Amethod is the character
122 -- designating the access method from the Access_Method field of the FCB.
124 function Errno_Message
126 Errno
: Integer := OS_Lib
.Errno
) return String;
127 -- Return Errno_Message for Errno, with file name prepended
129 procedure Raise_Device_Error
131 Errno
: Integer := OS_Lib
.Errno
);
132 pragma No_Return
(Raise_Device_Error
);
133 -- Clear error indication on File and raise Device_Error with an exception
134 -- message providing errno information.
140 procedure Append_Set
(File
: AFCB_Ptr
) is
142 if File
.Mode
= Append_File
then
143 if fseek
(File
.Stream
, 0, SEEK_END
) /= 0 then
144 Raise_Device_Error
(File
);
153 procedure Chain_File
(File
: AFCB_Ptr
) is
155 -- Take a task lock, to protect the global data value Open_Files
159 -- Do the chaining operation locked
161 File
.Next
:= Open_Files
;
165 if File
.Next
/= null then
166 File
.Next
.Prev
:= File
;
177 ---------------------
178 -- Check_File_Open --
179 ---------------------
181 procedure Check_File_Open
(File
: AFCB_Ptr
) is
184 raise Status_Error
with "file not open";
188 -----------------------
189 -- Check_Read_Status --
190 -----------------------
192 procedure Check_Read_Status
(File
: AFCB_Ptr
) is
195 raise Status_Error
with "file not open";
196 elsif File
.Mode
not in Read_File_Mode
then
197 raise Mode_Error
with "file not readable";
199 end Check_Read_Status
;
201 ------------------------
202 -- Check_Write_Status --
203 ------------------------
205 procedure Check_Write_Status
(File
: AFCB_Ptr
) is
208 raise Status_Error
with "file not open";
209 elsif File
.Mode
= In_File
then
210 raise Mode_Error
with "file not writable";
212 end Check_Write_Status
;
218 procedure Close
(File_Ptr
: access AFCB_Ptr
) is
219 Close_Status
: int
:= 0;
220 Dup_Strm
: Boolean := False;
221 Errno
: Integer := 0;
223 File
: AFCB_Ptr
renames File_Ptr
.all;
226 -- Take a task lock, to protect the global variables Open_Files and
227 -- Temp_Files, and the chains they point to.
231 Check_File_Open
(File
);
234 -- Sever the association between the given file and its associated
235 -- external file. The given file is left closed. Do not perform system
236 -- closes on the standard input, output and error files and also do not
237 -- attempt to close a stream that does not exist (signalled by a null
238 -- stream value -- happens in some error situations).
240 if not File
.Is_System_File
and then File
.Stream
/= NULL_Stream
then
242 -- Do not do an fclose if this is a shared file and there is at least
243 -- one other instance of the stream that is open.
245 if File
.Shared_Status
= Yes
then
252 if P
/= File
and then File
.Stream
= P
.Stream
then
262 -- Do the fclose unless this was a duplicate in the shared case
265 Close_Status
:= fclose
(File
.Stream
);
267 if Close_Status
/= 0 then
268 Errno
:= OS_Lib
.Errno
;
273 -- Dechain file from list of open files and then free the storage
275 if File
.Prev
= null then
276 Open_Files
:= File
.Next
;
278 File
.Prev
.Next
:= File
.Next
;
281 if File
.Next
/= null then
282 File
.Next
.Prev
:= File
.Prev
;
285 -- If it's a temp file, remove the corresponding record from Temp_Files,
286 -- and delete the file. There are unlikely to be large numbers of temp
287 -- files open, so a linear search is sufficiently efficient. Note that
288 -- we don't need to check for end of list, because the file must be
289 -- somewhere on the list. Note that as for Finalize, we ignore any
290 -- errors while attempting the unlink operation.
292 if File
.Is_Temporary_File
then
294 Temp
: access Temp_File_Record_Ptr
:= Temp_Files
'Access;
295 -- Note the double indirection here
298 New_Temp
: Temp_File_Record_Ptr
;
301 while Temp
.all.all.File
/= File
loop
302 Temp
:= Temp
.all.all.Next
'Access;
305 Discard
:= unlink
(Temp
.all.all.Name
'Address);
306 New_Temp
:= Temp
.all.all.Next
;
308 Temp
.all := New_Temp
;
312 -- Deallocate some parts of the file structure that were kept in heap
313 -- storage with the exception of system files (standard input, output
314 -- and error) since they had some information allocated in the stack.
316 if not File
.Is_System_File
then
317 Free_String
(File
.Name
);
318 Free_String
(File
.Form
);
324 if Close_Status
/= 0 then
325 Raise_Device_Error
(null, Errno
);
340 procedure Delete
(File_Ptr
: access AFCB_Ptr
) is
341 File
: AFCB_Ptr
renames File_Ptr
.all;
344 Check_File_Open
(File
);
346 if not File
.Is_Regular_File
then
347 raise Use_Error
with "cannot delete non-regular file";
351 Filename
: aliased constant String := File
.Name
.all;
352 Is_Temporary_File
: constant Boolean := File
.Is_Temporary_File
;
357 -- Now unlink the external file. Note that we use the full name in
358 -- this unlink, because the working directory may have changed since
359 -- we did the open, and we want to unlink the right file. However, if
360 -- it's a temporary file, then closing it already unlinked it.
362 if not Is_Temporary_File
then
363 if unlink
(Filename
'Address) = -1 then
364 raise Use_Error
with OS_Lib
.Errno_Message
;
374 function End_Of_File
(File
: AFCB_Ptr
) return Boolean is
376 Check_File_Open
(File
);
378 if feof
(File
.Stream
) /= 0 then
382 Check_Read_Status
(File
);
384 if ungetc
(fgetc
(File
.Stream
), File
.Stream
) = EOF
then
385 clearerr
(File
.Stream
);
397 function Errno_Message
399 Errno
: Integer := OS_Lib
.Errno
) return String
402 return Name
& ": " & OS_Lib
.Errno_Message
(Err
=> Errno
);
409 procedure Finalize
(V
: in out File_IO_Clean_Up_Type
) is
410 pragma Warnings
(Off
, V
);
412 Fptr1
: aliased AFCB_Ptr
;
418 -- Take a lock to protect global Open_Files data structure
422 -- First close all open files (the slightly complex form of this loop is
423 -- required because Close nulls out its argument).
426 while Fptr1
/= null loop
428 Close
(Fptr1
'Access);
432 -- Now unlink all temporary files. We do not bother to free the blocks
433 -- because we are just about to terminate the program. We also ignore
434 -- any errors while attempting these unlink operations.
436 while Temp_Files
/= null loop
437 Discard
:= unlink
(Temp_Files
.Name
'Address);
438 Temp_Files
:= Temp_Files
.Next
;
453 procedure Flush
(File
: AFCB_Ptr
) is
455 Check_Write_Status
(File
);
457 if fflush
(File
.Stream
) /= 0 then
458 Raise_Device_Error
(File
);
466 -- The fopen mode to be used is shown by the following table:
469 -- Append_File "r+" "w+"
471 -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w"
472 -- Out_File (others) "w" "w"
473 -- Inout_File "r+" "w+"
475 -- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a
476 -- named pipe), we use "w" instead of "r+". This is necessary to make a
477 -- write to the fifo block until a reader is ready.
479 -- Note: we do not use "a" or "a+" for Append_File, since this would not
480 -- work in the case of stream files, where even if in append file mode,
481 -- you can reset to earlier points in the file. The caller must use the
482 -- Append_Set routine to deal with the necessary positioning.
484 -- Note: in several cases, the fopen mode used allows reading and writing,
485 -- but the setting of the Ada mode is more restrictive. For instance,
486 -- Create in In_File mode uses "w+" which allows writing, but the Ada mode
487 -- In_File will cause any write operations to be rejected with Mode_Error
490 -- Note: for the Out_File/Open cases for other than the Direct_IO case, an
491 -- initial call will be made by the caller to first open the file in "r"
492 -- mode to be sure that it exists. The real open, in "w" mode, will then
493 -- destroy this file. This is peculiar, but that's what Ada semantics
494 -- require and the ACATS tests insist on.
496 -- If text file translation is required, then either "b" or "t" is appended
497 -- to the mode, depending on the setting of Text.
505 Fopstr
: out Fopen_String
)
509 function is_fifo
(Path
: Address
) return Integer;
510 pragma Import
(C
, is_fifo
, "__gnat_is_fifo");
525 if Amethod
in 'D' |
'S'
527 and then is_fifo
(Namestr
'Address) = 0
540 Fopstr
(1) := (if Creat
then 'w' else 'r');
545 -- If text_translation_required is true then we need to append either a
546 -- "t" or "b" to the string to get the right mode.
548 if text_translation_required
then
549 Fopstr
(Fptr
) := (if Text
then 't' else 'b');
553 Fopstr
(Fptr
) := ASCII
.NUL
;
560 function Form
(File
: AFCB_Ptr
) return String is
563 raise Status_Error
with "Form: file not open";
565 return File
.Form
.all (1 .. File
.Form
'Length - 1);
573 function Form_Boolean
576 Default
: Boolean) return Boolean
579 pragma Unreferenced
(V2
);
582 Form_Parameter
(Form
, Keyword
, V1
, V2
);
586 elsif Form
(V1
) = 'y' then
588 elsif Form
(V1
) = 'n' then
591 raise Use_Error
with "invalid Form";
599 function Form_Integer
602 Default
: Integer) return Integer
608 Form_Parameter
(Form
, Keyword
, V1
, V2
);
616 for J
in V1
.. V2
loop
617 if Form
(J
) not in '0' .. '9' then
618 raise Use_Error
with "invalid Form";
620 V
:= V
* 10 + Character'Pos (Form
(J
)) - Character'Pos ('0');
624 raise Use_Error
with "invalid Form";
636 procedure Form_Parameter
642 Klen
: constant Integer := Keyword
'Length;
645 for J
in Form
'First + Klen
.. Form
'Last - 1 loop
647 and then Form
(J
- Klen
.. J
- 1) = Keyword
651 while Form
(Stop
+ 1) /= ASCII
.NUL
652 and then Form
(Stop
+ 1) /= ','
669 function Is_Open
(File
: AFCB_Ptr
) return Boolean is
671 -- We return True if the file is open, and the underlying file stream is
672 -- usable. In particular on Windows an application linked with -mwindows
673 -- option set does not have a console attached. In this case standard
674 -- files (Current_Output, Current_Error, Current_Input) are not created.
675 -- We want Is_Open (Current_Output) to return False in this case.
677 return File
/= null and then fileno
(File
.Stream
) /= -1;
684 procedure Make_Buffered
686 Buf_Siz
: Interfaces
.C_Streams
.size_t
)
689 pragma Unreferenced
(status
);
692 status
:= setvbuf
(File
.Stream
, Null_Address
, IOFBF
, Buf_Siz
);
695 ------------------------
696 -- Make_Line_Buffered --
697 ------------------------
699 procedure Make_Line_Buffered
701 Line_Siz
: Interfaces
.C_Streams
.size_t
)
704 pragma Unreferenced
(status
);
707 status
:= setvbuf
(File
.Stream
, Null_Address
, IOLBF
, Line_Siz
);
708 -- No error checking???
709 end Make_Line_Buffered
;
711 ---------------------
712 -- Make_Unbuffered --
713 ---------------------
715 procedure Make_Unbuffered
(File
: AFCB_Ptr
) is
717 pragma Unreferenced
(status
);
720 status
:= setvbuf
(File
.Stream
, Null_Address
, IONBF
, 0);
721 -- No error checking???
728 function Mode
(File
: AFCB_Ptr
) return File_Mode
is
731 raise Status_Error
with "Mode: file not open";
741 function Name
(File
: AFCB_Ptr
) return String is
744 raise Status_Error
with "Name: file not open";
746 return File
.Name
.all (1 .. File
.Name
'Length - 1);
755 (File_Ptr
: in out AFCB_Ptr
;
756 Dummy_FCB
: AFCB
'Class;
763 C_Stream
: FILEs
:= NULL_Stream
)
765 pragma Warnings
(Off
, Dummy_FCB
);
766 -- Yes we know this is never assigned a value. That's intended, since
767 -- all we ever use of this value is the tag for dispatching purposes.
769 procedure Tmp_Name
(Buffer
: Address
);
770 pragma Import
(C
, Tmp_Name
, "__gnat_tmp_name");
771 -- Set buffer (a String address) with a temporary filename
773 function Get_Case_Sensitive
return Integer;
774 pragma Import
(C
, Get_Case_Sensitive
,
775 "__gnat_get_file_names_case_sensitive");
777 procedure Record_AFCB
;
778 -- Create and record new AFCB into the runtime, note that the
779 -- implementation uses the variables below which corresponds to the
780 -- status of the opened file.
782 File_Names_Case_Sensitive
: constant Boolean := Get_Case_Sensitive
/= 0;
783 -- Set to indicate whether the operating system convention is for file
784 -- names to be case sensitive (e.g., in Unix, set True), or not case
785 -- sensitive (e.g., in Windows, set False). Declared locally to avoid
786 -- breaking the Preelaborate rule that disallows function calls at the
789 Stream
: FILEs
:= C_Stream
;
790 -- Stream which we open in response to this request
792 Shared
: Shared_Status_Type
;
793 -- Setting of Shared_Status field for file
795 Fopstr
: aliased Fopen_String
;
796 -- Mode string used in fopen call
798 Formstr
: aliased String (1 .. Form
'Length + 1);
799 -- Form string with ASCII.NUL appended, folded to lower case
801 Text_Encoding
: Content_Encoding
;
803 Tempfile
: constant Boolean := Name
= "";
804 -- Indicates temporary file case, which is indicated by an empty file
807 Namelen
: constant Integer := max_path_len
;
808 -- Length required for file name, not including final ASCII.NUL.
809 -- Note that we used to reference L_tmpnam here, which is not reliable
810 -- since __gnat_tmp_name does not always use tmpnam.
812 Namestr
: aliased String (1 .. Namelen
+ 1);
813 -- Name as given or temporary file name with ASCII.NUL appended
815 Fullname
: aliased String (1 .. max_path_len
+ 1);
816 -- Full name (as required for Name function, and as stored in the
817 -- control block in the Name field) with ASCII.NUL appended.
819 Full_Name_Len
: Integer;
820 -- Length of name actually stored in Fullname
822 Encoding
: CRTL
.Filename_Encoding
;
823 -- Filename encoding specified into the form parameter
829 procedure Record_AFCB
is
831 File_Ptr
:= AFCB_Allocate
(Dummy_FCB
);
833 -- Note that we cannot use an aggregate here as File_Ptr is a
834 -- class-wide access to a limited type (Root_Stream_Type).
836 File_Ptr
.Is_Regular_File
:= is_regular_file
(fileno
(Stream
)) /= 0;
837 File_Ptr
.Is_System_File
:= False;
838 File_Ptr
.Text_Encoding
:= Text_Encoding
;
839 File_Ptr
.Shared_Status
:= Shared
;
840 File_Ptr
.Access_Method
:= Amethod
;
841 File_Ptr
.Stream
:= Stream
;
842 File_Ptr
.Form
:= new String'(Formstr);
843 File_Ptr.Name := new String'(Fullname
844 (1 .. Full_Name_Len
));
845 File_Ptr
.Mode
:= Mode
;
846 File_Ptr
.Is_Temporary_File
:= Tempfile
;
847 File_Ptr
.Encoding
:= Encoding
;
849 Chain_File
(File_Ptr
);
850 Append_Set
(File_Ptr
);
853 -- Start of processing for Open
856 if File_Ptr
/= null then
857 raise Status_Error
with "file already open";
860 -- Acquire form string, setting required NUL terminator
862 Formstr
(1 .. Form
'Length) := Form
;
863 Formstr
(Formstr
'Last) := ASCII
.NUL
;
865 -- Convert form string to lower case
867 for J
in Formstr
'Range loop
868 if Formstr
(J
) in 'A' .. 'Z' then
869 Formstr
(J
) := Character'Val (Character'Pos (Formstr
(J
)) + 32);
873 -- Acquire setting of shared parameter
879 Form_Parameter
(Formstr
, "shared", V1
, V2
);
883 elsif Formstr
(V1
.. V2
) = "yes" then
885 elsif Formstr
(V1
.. V2
) = "no" then
888 raise Use_Error
with "invalid Form";
892 -- Acquire setting of encoding parameter
898 Form_Parameter
(Formstr
, "encoding", V1
, V2
);
901 Encoding
:= CRTL
.Unspecified
;
902 elsif Formstr
(V1
.. V2
) = "utf8" then
903 Encoding
:= CRTL
.UTF8
;
904 elsif Formstr
(V1
.. V2
) = "8bits" then
905 Encoding
:= CRTL
.ASCII_8bits
;
907 raise Use_Error
with "invalid Form";
911 -- Acquire setting of text_translation parameter. Only needed if this is
912 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
913 -- if the Form says Text_Translation=No, we use binary mode, so new-line
914 -- will be just LF, even on Windows.
917 Text_Encoding
:= Default_Text
;
919 Text_Encoding
:= None
;
922 if Text_Encoding
in Text_Content_Encoding
then
927 Form_Parameter
(Formstr
, "text_translation", V1
, V2
);
931 elsif Formstr
(V1
.. V2
) = "no" then
932 Text_Encoding
:= None
;
933 elsif Formstr
(V1
.. V2
) = "text"
934 or else Formstr
(V1
.. V2
) = "yes"
936 Text_Encoding
:= Interfaces
.C_Streams
.Text
;
937 elsif Formstr
(V1
.. V2
) = "wtext" then
938 Text_Encoding
:= Wtext
;
939 elsif Formstr
(V1
.. V2
) = "u8text" then
940 Text_Encoding
:= U8text
;
941 elsif Formstr
(V1
.. V2
) = "u16text" then
942 Text_Encoding
:= U16text
;
944 raise Use_Error
with "invalid Form";
949 -- If we were given a stream (call from xxx.C_Streams.Open), then set
950 -- the full name to the given one, and skip to end of processing.
952 if Stream
/= NULL_Stream
then
953 Full_Name_Len
:= Name
'Length + 1;
954 Fullname
(1 .. Full_Name_Len
- 1) := Name
;
955 Fullname
(Full_Name_Len
) := ASCII
.NUL
;
957 -- Normal case of Open or Create
960 -- If temporary file case, get temporary file name and add to the
961 -- list of temporary files to be deleted on exit.
965 raise Name_Error
with "opening temp file without creating it";
968 Tmp_Name
(Namestr
'Address);
970 if Namestr
(1) = ASCII
.NUL
then
971 raise Use_Error
with "invalid temp file name";
974 -- Normal case of non-empty name given (i.e. not a temp file)
977 if Name
'Length > Namelen
then
978 raise Name_Error
with "file name too long";
981 Namestr
(1 .. Name
'Length) := Name
;
982 Namestr
(Name
'Length + 1) := ASCII
.NUL
;
985 -- Get full name in accordance with the advice of RM A.8.2(22)
987 full_name
(Namestr
'Address, Fullname
'Address);
989 if Fullname
(1) = ASCII
.NUL
then
990 raise Use_Error
with Errno_Message
(Name
);
994 while Full_Name_Len
< Fullname
'Last
995 and then Fullname
(Full_Name_Len
) /= ASCII
.NUL
997 Full_Name_Len
:= Full_Name_Len
+ 1;
1000 -- Fullname is generated by calling system's full_name. The problem
1001 -- is, full_name does nothing about the casing, so a file name
1002 -- comparison may generally speaking not be valid on non-case-
1003 -- sensitive systems, and in particular we get unexpected failures
1004 -- on Windows/Vista because of this. So we use s-casuti to force
1005 -- the name to lower case.
1007 if not File_Names_Case_Sensitive
then
1008 To_Lower
(Fullname
(1 .. Full_Name_Len
));
1011 -- If Shared=None or Shared=Yes, then check for the existence of
1012 -- another file with exactly the same full name.
1014 if Shared
/= No
then
1019 -- Take a task lock to protect Open_Files
1023 -- Search list of open files
1026 while P
/= null loop
1027 if Fullname
(1 .. Full_Name_Len
) = P
.Name
.all then
1029 -- If we get a match, and either file has Shared=None,
1030 -- then raise Use_Error, since we don't allow two files
1031 -- of the same name to be opened unless they specify the
1032 -- required sharing mode.
1035 or else P
.Shared_Status
= None
1037 raise Use_Error
with "reopening shared file";
1039 -- If both files have Shared=Yes, then we acquire the
1040 -- stream from the located file to use as our stream.
1043 and then P
.Shared_Status
= Yes
1048 pragma Assert
(not Tempfile
);
1052 -- Otherwise one of the files has Shared=Yes and one has
1053 -- Shared=No. If the current file has Shared=No then all
1054 -- is well but we don't want to share any other file's
1055 -- stream. If the current file has Shared=Yes, we would
1056 -- like to share a stream, but not from a file that has
1057 -- Shared=No, so either way, we just continue the search.
1067 SSL
.Unlock_Task
.all;
1071 SSL
.Unlock_Task
.all;
1076 -- Open specified file if we did not find an existing stream,
1077 -- otherwise we just return as there is nothing more to be done.
1079 if Stream
/= NULL_Stream
then
1084 (Namestr
=> Namestr
,
1086 Text
=> Text_Encoding
in Text_Content_Encoding
,
1091 -- A special case, if we are opening (OPEN case) a file and the
1092 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
1093 -- make sure that the file exists as required by Ada semantics.
1095 if not Creat
and then Fopstr
(1) /= 'r' then
1096 if file_exists
(Namestr
'Address) = 0 then
1097 raise Name_Error
with Errno_Message
(Name
);
1101 -- Now open the file. Note that we use the name as given in the
1102 -- original Open call for this purpose, since that seems the
1103 -- clearest implementation of the intent. It would presumably
1104 -- work to use the full name here, but if there is any difference,
1105 -- then we should use the name used in the call.
1107 -- Note: for a corresponding delete, we will use the full name,
1108 -- since by the time of the delete, the current working directory
1109 -- may have changed and we do not want to delete a different file.
1112 fopen
(Namestr
'Address, Fopstr
'Address, Encoding
);
1114 if Stream
= NULL_Stream
then
1116 -- Raise Name_Error if trying to open a non-existent file.
1117 -- Otherwise raise Use_Error.
1119 -- Should we raise Device_Error for ENOSPC???
1122 function Is_File_Not_Found_Error
1123 (Errno_Value
: Integer) return Integer;
1125 (C
, Is_File_Not_Found_Error
,
1126 "__gnat_is_file_not_found_error");
1127 -- Non-zero when the given errno value indicates a non-
1130 Errno
: constant Integer := OS_Lib
.Errno
;
1131 Message
: constant String := Errno_Message
(Name
, Errno
);
1134 if Is_File_Not_Found_Error
(Errno
) /= 0 then
1135 raise Name_Error
with Message
;
1137 raise Use_Error
with Message
;
1144 -- Stream has been successfully located or opened, so now we are
1145 -- committed to completing the opening of the file. Allocate block on
1146 -- heap and fill in its fields.
1151 -- Chain to temp file list, ensuring thread safety with a lock
1156 new Temp_File_Record
'
1157 (File => File_Ptr, Name => Namestr, Next => Temp_Files);
1158 SSL.Unlock_Task.all;
1162 SSL.Unlock_Task.all;
1168 ------------------------
1169 -- Raise_Device_Error --
1170 ------------------------
1172 procedure Raise_Device_Error
1174 Errno : Integer := OS_Lib.Errno)
1177 -- Clear error status so that the same error is not reported twice
1179 if File /= null then
1180 clearerr (File.Stream);
1183 raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
1184 end Raise_Device_Error;
1190 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1194 Nread := fread (Buf, 1, Siz, File.Stream);
1199 elsif ferror (File.Stream) /= 0 then
1200 Raise_Device_Error (File);
1202 elsif Nread = 0 then
1205 else -- 0 < Nread < Siz
1206 raise Data_Error with "not enough data read";
1213 Siz : Interfaces.C_Streams.size_t;
1214 Count : out Interfaces.C_Streams.size_t)
1217 Count := fread (Buf, 1, Siz, File.Stream);
1219 if Count = 0 and then ferror (File.Stream) /= 0 then
1220 Raise_Device_Error (File);
1228 -- The reset which does not change the mode simply does a rewind
1230 procedure Reset (File_Ptr : access AFCB_Ptr) is
1231 File : AFCB_Ptr renames File_Ptr.all;
1233 Check_File_Open (File);
1234 Reset (File_Ptr, File.Mode);
1237 -- The reset with a change in mode is done using freopen, and is not
1238 -- permitted except for regular files (since otherwise there is no name for
1239 -- the freopen, and in any case it seems meaningless).
1241 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
1242 File : AFCB_Ptr renames File_Ptr.all;
1243 Fopstr : aliased Fopen_String;
1246 Check_File_Open (File);
1248 -- Change of mode not allowed for shared file or file with no name or
1249 -- file that is not a regular file, or for a system file. Note that we
1250 -- allow the "change" of mode if it is not in fact doing a change.
1252 if Mode /= File.Mode then
1253 if File.Shared_Status = Yes then
1254 raise Use_Error with "cannot change mode of shared file";
1255 elsif File.Name'Length <= 1 then
1256 raise Use_Error with "cannot change mode of temp file";
1257 elsif File.Is_System_File then
1258 raise Use_Error with "cannot change mode of system file";
1259 elsif not File.Is_Regular_File then
1260 raise Use_Error with "cannot change mode of non-regular file";
1264 -- For In_File or Inout_File for a regular file, we can just do a rewind
1265 -- if the mode is unchanged, which is more efficient than doing a full
1269 and then Mode in Read_File_Mode
1271 rewind (File.Stream);
1273 -- Here the change of mode is permitted, we do it by reopening the file
1274 -- in the new mode and replacing the stream with a new stream.
1278 (Namestr => File.Name.all,
1280 Text => File.Text_Encoding in Text_Content_Encoding,
1282 Amethod => File.Access_Method,
1285 File.Stream := freopen
1286 (File.Name.all'Address, Fopstr'Address, File.Stream,
1289 if File.Stream = NULL_Stream then
1303 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1305 -- Note: for most purposes, the Siz and 1 parameters in the fwrite call
1306 -- could be reversed, but we have encountered systems where this is a
1307 -- better choice, since for some file formats, reversing the parameters
1308 -- results in records of one byte each.
1310 SSL.Abort_Defer.all;
1312 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1314 SSL.Abort_Undefer.all;
1315 Raise_Device_Error (File);
1319 SSL.Abort_Undefer.all;