1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- S Y S T E M . F I L E _ I O --
9 -- Copyright (C) 1992-2012, 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
;
36 with Interfaces
.C
.Strings
; use Interfaces
.C
.Strings
;
37 with Interfaces
.C_Streams
; use Interfaces
.C_Streams
;
39 with System
.CRTL
.Runtime
;
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
;
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 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 which 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)
115 Fopstr
: out Fopen_String
);
116 -- Determines proper open mode for a file to be opened in the given
117 -- Ada mode. Text is true for a text file and false otherwise, and
118 -- Creat is true for a create call, and False for an open call. The
119 -- value stored in Fopstr is a nul-terminated string suitable for a
120 -- call to fopen or freopen. Amethod is the character designating
121 -- the access method from the Access_Method field of the FCB.
123 function Errno_Message
124 (Errno
: Integer := OS_Lib
.Errno
) return String;
125 function Errno_Message
127 Errno
: Integer := OS_Lib
.Errno
) return String;
128 -- Return a message suitable for "raise ... with Errno_Message (...)".
129 -- Errno defaults to the current errno, but should be passed explicitly if
130 -- there is significant code in between the call that sets errno and the
131 -- call to Errno_Message, in case that code also sets errno. The version
132 -- with Name includes that file name in the message.
134 procedure Raise_Device_Error
135 (File
: AFCB_Ptr
; Errno
: Integer := OS_Lib
.Errno
);
136 pragma No_Return
(Raise_Device_Error
);
137 -- Clear error indication on File and raise Device_Error with an exception
138 -- message providing errno information.
144 procedure Append_Set
(File
: AFCB_Ptr
) is
146 if File
.Mode
= Append_File
then
147 if fseek
(File
.Stream
, 0, SEEK_END
) /= 0 then
148 Raise_Device_Error
(File
);
157 procedure Chain_File
(File
: AFCB_Ptr
) is
159 -- Take a task lock, to protect the global data value Open_Files
163 -- Do the chaining operation locked
165 File
.Next
:= Open_Files
;
169 if File
.Next
/= null then
170 File
.Next
.Prev
:= File
;
181 ---------------------
182 -- Check_File_Open --
183 ---------------------
185 procedure Check_File_Open
(File
: AFCB_Ptr
) is
188 raise Status_Error
with "file not open";
192 -----------------------
193 -- Check_Read_Status --
194 -----------------------
196 procedure Check_Read_Status
(File
: AFCB_Ptr
) is
199 raise Status_Error
with "file not open";
200 elsif File
.Mode
not in Read_File_Mode
then
201 raise Mode_Error
with "file not readable";
203 end Check_Read_Status
;
205 ------------------------
206 -- Check_Write_Status --
207 ------------------------
209 procedure Check_Write_Status
(File
: AFCB_Ptr
) is
212 raise Status_Error
with "file not open";
213 elsif File
.Mode
= In_File
then
214 raise Mode_Error
with "file not writable";
216 end Check_Write_Status
;
222 procedure Close
(File_Ptr
: access AFCB_Ptr
) is
223 Close_Status
: int
:= 0;
224 Dup_Strm
: Boolean := False;
225 File
: AFCB_Ptr
renames File_Ptr
.all;
229 -- Take a task lock, to protect the global data value Open_Files
233 Check_File_Open
(File
);
236 -- Sever the association between the given file and its associated
237 -- external file. The given file is left closed. Do not perform system
238 -- closes on the standard input, output and error files and also do not
239 -- attempt to close a stream that does not exist (signalled by a null
240 -- stream value -- happens in some error situations).
242 if not File
.Is_System_File
and then File
.Stream
/= NULL_Stream
then
244 -- Do not do an fclose if this is a shared file and there is at least
245 -- one other instance of the stream that is open.
247 if File
.Shared_Status
= Yes
then
254 if P
/= File
and then File
.Stream
= P
.Stream
then
264 -- Do the fclose unless this was a duplicate in the shared case
267 Close_Status
:= fclose
(File
.Stream
);
269 if Close_Status
/= 0 then
270 Errno
:= OS_Lib
.Errno
;
275 -- Dechain file from list of open files and then free the storage
277 if File
.Prev
= null then
278 Open_Files
:= File
.Next
;
280 File
.Prev
.Next
:= File
.Next
;
283 if File
.Next
/= null then
284 File
.Next
.Prev
:= File
.Prev
;
287 -- Deallocate some parts of the file structure that were kept in heap
288 -- storage with the exception of system files (standard input, output
289 -- and error) since they had some information allocated in the stack.
291 if not File
.Is_System_File
then
292 Free_String
(File
.Name
);
293 Free_String
(File
.Form
);
299 if Close_Status
/= 0 then
300 Raise_Device_Error
(null, Errno
);
315 procedure Delete
(File_Ptr
: access AFCB_Ptr
) is
316 File
: AFCB_Ptr
renames File_Ptr
.all;
319 Check_File_Open
(File
);
321 if not File
.Is_Regular_File
then
322 raise Use_Error
with "cannot delete non-regular file";
326 Filename
: aliased constant String := File
.Name
.all;
331 -- Now unlink the external file. Note that we use the full name in
332 -- this unlink, because the working directory may have changed since
333 -- we did the open, and we want to unlink the right file!
335 if unlink
(Filename
'Address) = -1 then
336 raise Use_Error
with Errno_Message
;
345 function End_Of_File
(File
: AFCB_Ptr
) return Boolean is
347 Check_File_Open
(File
);
349 if feof
(File
.Stream
) /= 0 then
353 Check_Read_Status
(File
);
355 if ungetc
(fgetc
(File
.Stream
), File
.Stream
) = EOF
then
356 clearerr
(File
.Stream
);
368 function Errno_Message
(Errno
: Integer := OS_Lib
.Errno
) return String is
369 Message
: constant chars_ptr
:= CRTL
.Runtime
.strerror
(Errno
);
372 if Message
= Null_Ptr
then
373 return "errno =" & Errno
'Img;
375 return Value
(Message
);
379 function Errno_Message
381 Errno
: Integer := OS_Lib
.Errno
) return String
384 return Name
& ": " & String'(Errno_Message (Errno));
391 -- Note: we do not need to worry about locking against multiple task access
392 -- in this routine, since it is called only from the environment task just
393 -- before terminating execution.
395 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
396 pragma Warnings (Off, V);
398 Fptr1 : aliased AFCB_Ptr;
402 pragma Unreferenced (Discard);
405 -- Take a lock to protect global Open_Files data structure
409 -- First close all open files (the slightly complex form of this loop is
410 -- required because Close as a side effect nulls out its argument).
413 while Fptr1 /= null loop
415 Close (Fptr1'Access);
419 -- Now unlink all temporary files. We do not bother to free the blocks
420 -- because we are just about to terminate the program. We also ignore
421 -- any errors while attempting these unlink operations.
423 while Temp_Files /= null loop
424 Discard := unlink (Temp_Files.Name'Address);
425 Temp_Files := Temp_Files.Next;
440 procedure Flush (File : AFCB_Ptr) is
442 Check_Write_Status (File);
444 if fflush (File.Stream) /= 0 then
445 Raise_Device_Error (File);
453 -- The fopen mode to be used is shown by the following table:
456 -- Append_File "r+" "w+"
458 -- Out_File (Direct_IO) "r+" "w"
459 -- Out_File (all others) "w" "w"
460 -- Inout_File "r+" "w+"
462 -- Note: we do not use "a" or "a+" for Append_File, since this would not
463 -- work in the case of stream files, where even if in append file mode,
464 -- you can reset to earlier points in the file. The caller must use the
465 -- Append_Set routine to deal with the necessary positioning.
467 -- Note: in several cases, the fopen mode used allows reading and writing,
468 -- but the setting of the Ada mode is more restrictive. For instance,
469 -- Create in In_File mode uses "w+" which allows writing, but the Ada mode
470 -- In_File will cause any write operations to be rejected with Mode_Error
473 -- Note: for the Out_File/Open cases for other than the Direct_IO case, an
474 -- initial call will be made by the caller to first open the file in "r"
475 -- mode to be sure that it exists. The real open, in "w" mode, will then
476 -- destroy this file. This is peculiar, but that's what Ada semantics
477 -- require and the ACATS tests insist on!
479 -- If text file translation is required, then either "b" or "t" is appended
480 -- to the mode, depending on the setting of Text.
487 Fopstr : out Fopen_String)
504 if Amethod = 'D
' and then not Creat then
513 when Inout_File | Append_File =>
514 Fopstr (1) := (if Creat then 'w
' else 'r
');
520 -- If text_translation_required is true then we need to append either a
521 -- "t" or "b" to the string to get the right mode.
523 if text_translation_required then
524 Fopstr (Fptr) := (if Text then 't
' else 'b
');
528 Fopstr (Fptr) := ASCII.NUL;
535 function Form (File : AFCB_Ptr) return String is
538 raise Status_Error with "Form: file not open";
540 return File.Form.all (1 .. File.Form'Length - 1);
548 function Form_Boolean
551 Default : Boolean) return Boolean
554 pragma Unreferenced (V2);
557 Form_Parameter (Form, Keyword, V1, V2);
562 elsif Form (V1) = 'y
' then
565 elsif Form (V1) = 'n
' then
569 raise Use_Error with "invalid Form";
577 function Form_Integer
580 Default : Integer) return Integer
586 Form_Parameter (Form, Keyword, V1, V2);
594 for J in V1 .. V2 loop
595 if Form (J) not in '0' .. '9' then
596 raise Use_Error with "invalid Form";
598 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
602 raise Use_Error with "invalid Form";
614 procedure Form_Parameter
620 Klen : constant Integer := Keyword'Length;
623 for J in Form'First + Klen .. Form'Last - 1 loop
625 and then Form (J - Klen .. J - 1) = Keyword
629 while Form (Stop + 1) /= ASCII.NUL
630 and then Form (Stop + 1) /= ','
647 function Is_Open (File : AFCB_Ptr) return Boolean is
649 -- We return True if the file is open, and the underlying file stream is
650 -- usable. In particular on Windows an application linked with -mwindows
651 -- option set does not have a console attached. In this case standard
652 -- files (Current_Output, Current_Error, Current_Input) are not created.
653 -- We want Is_Open (Current_Output) to return False in this case.
655 return File /= null and then fileno (File.Stream) /= -1;
662 procedure Make_Buffered
664 Buf_Siz : Interfaces.C_Streams.size_t)
667 pragma Unreferenced (status);
670 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
673 ------------------------
674 -- Make_Line_Buffered --
675 ------------------------
677 procedure Make_Line_Buffered
679 Line_Siz : Interfaces.C_Streams.size_t)
682 pragma Unreferenced (status);
685 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
686 -- No error checking???
687 end Make_Line_Buffered;
689 ---------------------
690 -- Make_Unbuffered --
691 ---------------------
693 procedure Make_Unbuffered (File : AFCB_Ptr) is
695 pragma Unreferenced (status);
698 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
699 -- No error checking???
706 function Mode (File : AFCB_Ptr) return File_Mode is
709 raise Status_Error with "Mode: file not open";
719 function Name (File : AFCB_Ptr) return String is
722 raise Status_Error with "Name: file not open";
724 return File.Name.all (1 .. File.Name'Length - 1);
733 (File_Ptr : in out AFCB_Ptr;
734 Dummy_FCB : AFCB'Class;
741 C_Stream : FILEs := NULL_Stream)
743 pragma Warnings (Off, Dummy_FCB);
744 -- Yes we know this is never assigned a value. That's intended, since
745 -- all we ever use of this value is the tag for dispatching purposes.
747 procedure Tmp_Name (Buffer : Address);
748 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
749 -- Set buffer (a String address) with a temporary filename
751 function Get_Case_Sensitive return Integer;
752 pragma Import (C, Get_Case_Sensitive,
753 "__gnat_get_file_names_case_sensitive");
755 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
756 -- Set to indicate whether the operating system convention is for file
757 -- names to be case sensitive (e.g., in Unix, set True), or not case
758 -- sensitive (e.g., in Windows, set False). Declared locally to avoid
759 -- breaking the Preelaborate rule that disallows function calls at the
762 Stream : FILEs := C_Stream;
763 -- Stream which we open in response to this request
765 Shared : Shared_Status_Type;
766 -- Setting of Shared_Status field for file
768 Fopstr : aliased Fopen_String;
769 -- Mode string used in fopen call
771 Formstr : aliased String (1 .. Form'Length + 1);
772 -- Form string with ASCII.NUL appended, folded to lower case
774 Is_Text_File : Boolean;
776 Tempfile : constant Boolean := (Name'Length = 0);
777 -- Indicates temporary file case
779 Namelen : constant Integer := max_path_len;
780 -- Length required for file name, not including final ASCII.NUL.
781 -- Note that we used to reference L_tmpnam here, which is not reliable
782 -- since __gnat_tmp_name does not always use tmpnam.
784 Namestr : aliased String (1 .. Namelen + 1);
785 -- Name as given or temporary file name with ASCII.NUL appended
787 Fullname : aliased String (1 .. max_path_len + 1);
788 -- Full name (as required for Name function, and as stored in the
789 -- control block in the Name field) with ASCII.NUL appended.
791 Full_Name_Len : Integer;
792 -- Length of name actually stored in Fullname
794 Encoding : CRTL.Filename_Encoding;
795 -- Filename encoding specified into the form parameter
798 if File_Ptr /= null then
799 raise Status_Error with "file already open";
802 -- Acquire form string, setting required NUL terminator
804 Formstr (1 .. Form'Length) := Form;
805 Formstr (Formstr'Last) := ASCII.NUL;
807 -- Convert form string to lower case
809 for J in Formstr'Range loop
810 if Formstr (J) in 'A
' .. 'Z
' then
811 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
815 -- Acquire setting of shared parameter
821 Form_Parameter (Formstr, "shared", V1, V2);
826 elsif Formstr (V1 .. V2) = "yes" then
829 elsif Formstr (V1 .. V2) = "no" then
833 raise Use_Error with "invalid Form";
837 -- Acquire setting of encoding parameter
843 Form_Parameter (Formstr, "encoding", V1, V2);
846 Encoding := CRTL.Unspecified;
848 elsif Formstr (V1 .. V2) = "utf8" then
849 Encoding := CRTL.UTF8;
851 elsif Formstr (V1 .. V2) = "8bits" then
852 Encoding := CRTL.ASCII_8bits;
855 raise Use_Error with "invalid Form";
859 -- Acquire setting of text_translation parameter. Only needed if this is
860 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
861 -- if the Form says Text_Translation=No, we use binary mode, so new-line
862 -- will be just LF, even on Windows.
864 Is_Text_File := Text;
868 Form_Boolean (Formstr, "text_translation", Default => True);
871 -- If we were given a stream (call from xxx.C_Streams.Open), then set
872 -- the full name to the given one, and skip to end of processing.
874 if Stream /= NULL_Stream then
875 Full_Name_Len := Name'Length + 1;
876 Fullname (1 .. Full_Name_Len - 1) := Name;
877 Fullname (Full_Name_Len) := ASCII.NUL;
879 -- Normal case of Open or Create
882 -- If temporary file case, get temporary file name and add to the
883 -- list of temporary files to be deleted on exit.
887 raise Name_Error with "opening temp file without creating it";
890 Tmp_Name (Namestr'Address);
892 if Namestr (1) = ASCII.NUL then
893 raise Use_Error with "invalid temp file name";
896 -- Chain to temp file list, ensuring thread safety with a lock
901 new Temp_File_Record'(Name
=> Namestr
, Next
=> Temp_Files
);
910 -- Normal case of non-null name given
913 if Name
'Length > Namelen
then
914 raise Name_Error
with "file name too long";
917 Namestr
(1 .. Name
'Length) := Name
;
918 Namestr
(Name
'Length + 1) := ASCII
.NUL
;
921 -- Get full name in accordance with the advice of RM A.8.2(22)
923 full_name
(Namestr
'Address, Fullname
'Address);
925 if Fullname
(1) = ASCII
.NUL
then
926 raise Use_Error
with Errno_Message
(Name
);
930 while Full_Name_Len
< Fullname
'Last
931 and then Fullname
(Full_Name_Len
) /= ASCII
.NUL
933 Full_Name_Len
:= Full_Name_Len
+ 1;
936 -- Fullname is generated by calling system's full_name. The problem
937 -- is, full_name does nothing about the casing, so a file name
938 -- comparison may generally speaking not be valid on non-case-
939 -- sensitive systems, and in particular we get unexpected failures
940 -- on Windows/Vista because of this. So we use s-casuti to force
941 -- the name to lower case.
943 if not File_Names_Case_Sensitive
then
944 To_Lower
(Fullname
(1 .. Full_Name_Len
));
947 -- If Shared=None or Shared=Yes, then check for the existence of
948 -- another file with exactly the same full name.
955 -- Take a task lock to protect Open_Files
959 -- Search list of open files
963 if Fullname
(1 .. Full_Name_Len
) = P
.Name
.all then
965 -- If we get a match, and either file has Shared=None,
966 -- then raise Use_Error, since we don't allow two files
967 -- of the same name to be opened unless they specify the
968 -- required sharing mode.
971 or else P
.Shared_Status
= None
973 raise Use_Error
with "reopening shared file";
975 -- If both files have Shared=Yes, then we acquire the
976 -- stream from the located file to use as our stream.
979 and then P
.Shared_Status
= Yes
984 -- Otherwise one of the files has Shared=Yes and one has
985 -- Shared=No. If the current file has Shared=No then all
986 -- is well but we don't want to share any other file's
987 -- stream. If the current file has Shared=Yes, we would
988 -- like to share a stream, but not from a file that has
989 -- Shared=No, so either way, we just continue the search.
1003 SSL
.Unlock_Task
.all;
1008 -- Open specified file if we did not find an existing stream
1010 if Stream
= NULL_Stream
then
1011 Fopen_Mode
(Mode
, Is_Text_File
, Creat
, Amethod
, Fopstr
);
1013 -- A special case, if we are opening (OPEN case) a file and the
1014 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
1015 -- make sure that the file exists as required by Ada semantics.
1017 if not Creat
and then Fopstr
(1) /= 'r' then
1018 if file_exists
(Namestr
'Address) = 0 then
1019 raise Name_Error
with Errno_Message
(Name
);
1023 -- Now open the file. Note that we use the name as given in the
1024 -- original Open call for this purpose, since that seems the
1025 -- clearest implementation of the intent. It would presumably
1026 -- work to use the full name here, but if there is any difference,
1027 -- then we should use the name used in the call.
1029 -- Note: for a corresponding delete, we will use the full name,
1030 -- since by the time of the delete, the current working directory
1031 -- may have changed and we do not want to delete a different file!
1033 Stream
:= fopen
(Namestr
'Address, Fopstr
'Address, Encoding
);
1035 if Stream
= NULL_Stream
then
1037 -- Raise Name_Error if trying to open a non-existent file.
1038 -- Otherwise raise Use_Error.
1040 -- Should we raise Device_Error for ENOSPC???
1043 function Is_File_Not_Found_Error
1044 (Errno_Value
: Integer) return Integer;
1045 -- Non-zero when the given errno value indicates a non-
1049 (C
, Is_File_Not_Found_Error
,
1050 "__gnat_is_file_not_found_error");
1052 Errno
: constant Integer := OS_Lib
.Errno
;
1053 Message
: constant String := Errno_Message
(Name
, Errno
);
1055 if Is_File_Not_Found_Error
(Errno
) /= 0 then
1056 raise Name_Error
with Message
;
1058 raise Use_Error
with Message
;
1065 -- Stream has been successfully located or opened, so now we are
1066 -- committed to completing the opening of the file. Allocate block on
1067 -- heap and fill in its fields.
1069 File_Ptr
:= AFCB_Allocate
(Dummy_FCB
);
1071 File_Ptr
.Is_Regular_File
:= (is_regular_file
(fileno
(Stream
)) /= 0);
1072 File_Ptr
.Is_System_File
:= False;
1073 File_Ptr
.Is_Text_File
:= Is_Text_File
;
1074 File_Ptr
.Shared_Status
:= Shared
;
1075 File_Ptr
.Access_Method
:= Amethod
;
1076 File_Ptr
.Stream
:= Stream
;
1077 File_Ptr
.Form
:= new String'(Formstr);
1078 File_Ptr.Name := new String'(Fullname
(1 .. Full_Name_Len
));
1079 File_Ptr
.Mode
:= Mode
;
1080 File_Ptr
.Is_Temporary_File
:= Tempfile
;
1081 File_Ptr
.Encoding
:= Encoding
;
1083 Chain_File
(File_Ptr
);
1084 Append_Set
(File_Ptr
);
1087 ------------------------
1088 -- Raise_Device_Error --
1089 ------------------------
1091 procedure Raise_Device_Error
1092 (File
: AFCB_Ptr
; Errno
: Integer := OS_Lib
.Errno
)
1095 -- Clear error status so that the same error is not reported twice
1097 if File
/= null then
1098 clearerr
(File
.Stream
);
1101 raise Device_Error
with Errno_Message
(Errno
);
1102 end Raise_Device_Error
;
1108 procedure Read_Buf
(File
: AFCB_Ptr
; Buf
: Address
; Siz
: size_t
) is
1112 Nread
:= fread
(Buf
, 1, Siz
, File
.Stream
);
1117 elsif ferror
(File
.Stream
) /= 0 then
1118 Raise_Device_Error
(File
);
1120 elsif Nread
= 0 then
1123 else -- 0 < Nread < Siz
1124 raise Data_Error
with "not enough data read";
1132 Siz
: Interfaces
.C_Streams
.size_t
;
1133 Count
: out Interfaces
.C_Streams
.size_t
)
1136 Count
:= fread
(Buf
, 1, Siz
, File
.Stream
);
1138 if Count
= 0 and then ferror
(File
.Stream
) /= 0 then
1139 Raise_Device_Error
(File
);
1147 -- The reset which does not change the mode simply does a rewind
1149 procedure Reset
(File_Ptr
: access AFCB_Ptr
) is
1150 File
: AFCB_Ptr
renames File_Ptr
.all;
1152 Check_File_Open
(File
);
1153 Reset
(File_Ptr
, File
.Mode
);
1156 -- The reset with a change in mode is done using freopen, and is not
1157 -- permitted except for regular files (since otherwise there is no name for
1158 -- the freopen, and in any case it seems meaningless).
1160 procedure Reset
(File_Ptr
: access AFCB_Ptr
; Mode
: File_Mode
) is
1161 File
: AFCB_Ptr
renames File_Ptr
.all;
1162 Fopstr
: aliased Fopen_String
;
1165 Check_File_Open
(File
);
1167 -- Change of mode not allowed for shared file or file with no name or
1168 -- file that is not a regular file, or for a system file. Note that we
1169 -- allow the "change" of mode if it is not in fact doing a change.
1171 if Mode
/= File
.Mode
then
1172 if File
.Shared_Status
= Yes
then
1173 raise Use_Error
with "cannot change mode of shared file";
1174 elsif File
.Name
'Length <= 1 then
1175 raise Use_Error
with "cannot change mode of temp file";
1176 elsif File
.Is_System_File
then
1177 raise Use_Error
with "cannot change mode of system file";
1178 elsif not File
.Is_Regular_File
then
1179 raise Use_Error
with "cannot change mode of non-regular file";
1183 -- For In_File or Inout_File for a regular file, we can just do a rewind
1184 -- if the mode is unchanged, which is more efficient than doing a full
1188 and then Mode
in Read_File_Mode
1190 rewind
(File
.Stream
);
1192 -- Here the change of mode is permitted, we do it by reopening the file
1193 -- in the new mode and replacing the stream with a new stream.
1197 (Mode
, File
.Is_Text_File
, False, File
.Access_Method
, Fopstr
);
1199 File
.Stream
:= freopen
1200 (File
.Name
.all'Address, Fopstr
'Address, File
.Stream
, File
.Encoding
);
1202 if File
.Stream
= NULL_Stream
then
1217 procedure Write_Buf
(File
: AFCB_Ptr
; Buf
: Address
; Siz
: size_t
) is
1219 -- Note: for most purposes, the Siz and 1 parameters in the fwrite call
1220 -- could be reversed, but on VMS, this is a better choice, since for
1221 -- some file formats, reversing the parameters results in records of one
1224 SSL
.Abort_Defer
.all;
1226 if fwrite
(Buf
, Siz
, 1, File
.Stream
) /= 1 then
1228 SSL
.Abort_Undefer
.all;
1229 Raise_Device_Error
(File
);
1233 SSL
.Abort_Undefer
.all;