|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . F I L E _ I O --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Finalization; use Ada.Finalization;
|
|
|
33 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
|
|
|
34 with Ada.Unchecked_Deallocation;
|
|
|
35
|
|
|
36 with Interfaces.C_Streams; use Interfaces.C_Streams;
|
|
|
37
|
|
|
38 with System.Case_Util; use System.Case_Util;
|
|
|
39 with System.CRTL;
|
|
|
40 with System.OS_Lib;
|
|
|
41 with System.Soft_Links;
|
|
|
42
|
|
|
43 package body System.File_IO is
|
|
|
44
|
|
|
45 use System.File_Control_Block;
|
|
|
46
|
|
|
47 package SSL renames System.Soft_Links;
|
|
|
48
|
|
|
49 use type CRTL.size_t;
|
|
|
50
|
|
|
51 ----------------------
|
|
|
52 -- Global Variables --
|
|
|
53 ----------------------
|
|
|
54
|
|
|
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.
|
|
|
60
|
|
|
61 type Temp_File_Record;
|
|
|
62 type Temp_File_Record_Ptr is access all Temp_File_Record;
|
|
|
63
|
|
|
64 type Temp_File_Record is record
|
|
|
65 File : AFCB_Ptr;
|
|
|
66 Next : aliased Temp_File_Record_Ptr;
|
|
|
67 Name : String (1 .. max_path_len + 1);
|
|
|
68 end record;
|
|
|
69 -- One of these is allocated for each temporary file created
|
|
|
70
|
|
|
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.
|
|
|
74
|
|
|
75 procedure Free is new Ada.Unchecked_Deallocation
|
|
|
76 (Temp_File_Record, Temp_File_Record_Ptr);
|
|
|
77
|
|
|
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.
|
|
|
85
|
|
|
86 procedure Finalize (V : in out File_IO_Clean_Up_Type);
|
|
|
87 -- This is the finalize operation that is used to do the cleanup
|
|
|
88
|
|
|
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.
|
|
|
94
|
|
|
95 text_translation_required : Boolean;
|
|
|
96 for text_translation_required'Size use Character'Size;
|
|
|
97 pragma Import
|
|
|
98 (C, text_translation_required, "__gnat_text_translation_required");
|
|
|
99 -- If true, add appropriate suffix to control string for Open
|
|
|
100
|
|
|
101 -----------------------
|
|
|
102 -- Local Subprograms --
|
|
|
103 -----------------------
|
|
|
104
|
|
|
105 procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
|
|
|
106
|
|
|
107 subtype Fopen_String is String (1 .. 4);
|
|
|
108 -- Holds open string (longest is "w+b" & nul)
|
|
|
109
|
|
|
110 procedure Fopen_Mode
|
|
|
111 (Namestr : String;
|
|
|
112 Mode : File_Mode;
|
|
|
113 Text : Boolean;
|
|
|
114 Creat : Boolean;
|
|
|
115 Amethod : Character;
|
|
|
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.
|
|
|
123
|
|
|
124 function Errno_Message
|
|
|
125 (Name : String;
|
|
|
126 Errno : Integer := OS_Lib.Errno) return String;
|
|
|
127 -- Return Errno_Message for Errno, with file name prepended
|
|
|
128
|
|
|
129 procedure Raise_Device_Error
|
|
|
130 (File : AFCB_Ptr;
|
|
|
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.
|
|
|
135
|
|
|
136 ----------------
|
|
|
137 -- Append_Set --
|
|
|
138 ----------------
|
|
|
139
|
|
|
140 procedure Append_Set (File : AFCB_Ptr) is
|
|
|
141 begin
|
|
|
142 if File.Mode = Append_File then
|
|
|
143 if fseek (File.Stream, 0, SEEK_END) /= 0 then
|
|
|
144 Raise_Device_Error (File);
|
|
|
145 end if;
|
|
|
146 end if;
|
|
|
147 end Append_Set;
|
|
|
148
|
|
|
149 ----------------
|
|
|
150 -- Chain_File --
|
|
|
151 ----------------
|
|
|
152
|
|
|
153 procedure Chain_File (File : AFCB_Ptr) is
|
|
|
154 begin
|
|
|
155 -- Take a task lock, to protect the global data value Open_Files
|
|
|
156
|
|
|
157 SSL.Lock_Task.all;
|
|
|
158
|
|
|
159 -- Do the chaining operation locked
|
|
|
160
|
|
|
161 File.Next := Open_Files;
|
|
|
162 File.Prev := null;
|
|
|
163 Open_Files := File;
|
|
|
164
|
|
|
165 if File.Next /= null then
|
|
|
166 File.Next.Prev := File;
|
|
|
167 end if;
|
|
|
168
|
|
|
169 SSL.Unlock_Task.all;
|
|
|
170
|
|
|
171 exception
|
|
|
172 when others =>
|
|
|
173 SSL.Unlock_Task.all;
|
|
|
174 raise;
|
|
|
175 end Chain_File;
|
|
|
176
|
|
|
177 ---------------------
|
|
|
178 -- Check_File_Open --
|
|
|
179 ---------------------
|
|
|
180
|
|
|
181 procedure Check_File_Open (File : AFCB_Ptr) is
|
|
|
182 begin
|
|
|
183 if File = null then
|
|
|
184 raise Status_Error with "file not open";
|
|
|
185 end if;
|
|
|
186 end Check_File_Open;
|
|
|
187
|
|
|
188 -----------------------
|
|
|
189 -- Check_Read_Status --
|
|
|
190 -----------------------
|
|
|
191
|
|
|
192 procedure Check_Read_Status (File : AFCB_Ptr) is
|
|
|
193 begin
|
|
|
194 if File = null then
|
|
|
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";
|
|
|
198 end if;
|
|
|
199 end Check_Read_Status;
|
|
|
200
|
|
|
201 ------------------------
|
|
|
202 -- Check_Write_Status --
|
|
|
203 ------------------------
|
|
|
204
|
|
|
205 procedure Check_Write_Status (File : AFCB_Ptr) is
|
|
|
206 begin
|
|
|
207 if File = null then
|
|
|
208 raise Status_Error with "file not open";
|
|
|
209 elsif File.Mode = In_File then
|
|
|
210 raise Mode_Error with "file not writable";
|
|
|
211 end if;
|
|
|
212 end Check_Write_Status;
|
|
|
213
|
|
|
214 -----------
|
|
|
215 -- Close --
|
|
|
216 -----------
|
|
|
217
|
|
|
218 procedure Close (File_Ptr : access AFCB_Ptr) is
|
|
|
219 Close_Status : int := 0;
|
|
|
220 Dup_Strm : Boolean := False;
|
|
|
221 Errno : Integer := 0;
|
|
|
222
|
|
|
223 File : AFCB_Ptr renames File_Ptr.all;
|
|
|
224
|
|
|
225 begin
|
|
|
226 -- Take a task lock, to protect the global variables Open_Files and
|
|
|
227 -- Temp_Files, and the chains they point to.
|
|
|
228
|
|
|
229 SSL.Lock_Task.all;
|
|
|
230
|
|
|
231 Check_File_Open (File);
|
|
|
232 AFCB_Close (File);
|
|
|
233
|
|
|
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).
|
|
|
239
|
|
|
240 if not File.Is_System_File and then File.Stream /= NULL_Stream then
|
|
|
241
|
|
|
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.
|
|
|
244
|
|
|
245 if File.Shared_Status = Yes then
|
|
|
246 declare
|
|
|
247 P : AFCB_Ptr;
|
|
|
248
|
|
|
249 begin
|
|
|
250 P := Open_Files;
|
|
|
251 while P /= null loop
|
|
|
252 if P /= File and then File.Stream = P.Stream then
|
|
|
253 Dup_Strm := True;
|
|
|
254 exit;
|
|
|
255 end if;
|
|
|
256
|
|
|
257 P := P.Next;
|
|
|
258 end loop;
|
|
|
259 end;
|
|
|
260 end if;
|
|
|
261
|
|
|
262 -- Do the fclose unless this was a duplicate in the shared case
|
|
|
263
|
|
|
264 if not Dup_Strm then
|
|
|
265 Close_Status := fclose (File.Stream);
|
|
|
266
|
|
|
267 if Close_Status /= 0 then
|
|
|
268 Errno := OS_Lib.Errno;
|
|
|
269 end if;
|
|
|
270 end if;
|
|
|
271 end if;
|
|
|
272
|
|
|
273 -- Dechain file from list of open files and then free the storage
|
|
|
274
|
|
|
275 if File.Prev = null then
|
|
|
276 Open_Files := File.Next;
|
|
|
277 else
|
|
|
278 File.Prev.Next := File.Next;
|
|
|
279 end if;
|
|
|
280
|
|
|
281 if File.Next /= null then
|
|
|
282 File.Next.Prev := File.Prev;
|
|
|
283 end if;
|
|
|
284
|
|
|
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.
|
|
|
291
|
|
|
292 if File.Is_Temporary_File then
|
|
|
293 declare
|
|
|
294 Temp : access Temp_File_Record_Ptr := Temp_Files'Access;
|
|
|
295 -- Note the double indirection here
|
|
|
296
|
|
|
297 Discard : int;
|
|
|
298 New_Temp : Temp_File_Record_Ptr;
|
|
|
299
|
|
|
300 begin
|
|
|
301 while Temp.all.all.File /= File loop
|
|
|
302 Temp := Temp.all.all.Next'Access;
|
|
|
303 end loop;
|
|
|
304
|
|
|
305 Discard := unlink (Temp.all.all.Name'Address);
|
|
|
306 New_Temp := Temp.all.all.Next;
|
|
|
307 Free (Temp.all);
|
|
|
308 Temp.all := New_Temp;
|
|
|
309 end;
|
|
|
310 end if;
|
|
|
311
|
|
|
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.
|
|
|
315
|
|
|
316 if not File.Is_System_File then
|
|
|
317 Free_String (File.Name);
|
|
|
318 Free_String (File.Form);
|
|
|
319 AFCB_Free (File);
|
|
|
320 end if;
|
|
|
321
|
|
|
322 File := null;
|
|
|
323
|
|
|
324 if Close_Status /= 0 then
|
|
|
325 Raise_Device_Error (null, Errno);
|
|
|
326 end if;
|
|
|
327
|
|
|
328 SSL.Unlock_Task.all;
|
|
|
329
|
|
|
330 exception
|
|
|
331 when others =>
|
|
|
332 SSL.Unlock_Task.all;
|
|
|
333 raise;
|
|
|
334 end Close;
|
|
|
335
|
|
|
336 ------------
|
|
|
337 -- Delete --
|
|
|
338 ------------
|
|
|
339
|
|
|
340 procedure Delete (File_Ptr : access AFCB_Ptr) is
|
|
|
341 File : AFCB_Ptr renames File_Ptr.all;
|
|
|
342
|
|
|
343 begin
|
|
|
344 Check_File_Open (File);
|
|
|
345
|
|
|
346 if not File.Is_Regular_File then
|
|
|
347 raise Use_Error with "cannot delete non-regular file";
|
|
|
348 end if;
|
|
|
349
|
|
|
350 declare
|
|
|
351 Filename : aliased constant String := File.Name.all;
|
|
|
352 Is_Temporary_File : constant Boolean := File.Is_Temporary_File;
|
|
|
353
|
|
|
354 begin
|
|
|
355 Close (File_Ptr);
|
|
|
356
|
|
|
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.
|
|
|
361
|
|
|
362 if not Is_Temporary_File then
|
|
|
363 if unlink (Filename'Address) = -1 then
|
|
|
364 raise Use_Error with OS_Lib.Errno_Message;
|
|
|
365 end if;
|
|
|
366 end if;
|
|
|
367 end;
|
|
|
368 end Delete;
|
|
|
369
|
|
|
370 -----------------
|
|
|
371 -- End_Of_File --
|
|
|
372 -----------------
|
|
|
373
|
|
|
374 function End_Of_File (File : AFCB_Ptr) return Boolean is
|
|
|
375 begin
|
|
|
376 Check_File_Open (File);
|
|
|
377
|
|
|
378 if feof (File.Stream) /= 0 then
|
|
|
379 return True;
|
|
|
380
|
|
|
381 else
|
|
|
382 Check_Read_Status (File);
|
|
|
383
|
|
|
384 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
|
|
|
385 clearerr (File.Stream);
|
|
|
386 return True;
|
|
|
387 else
|
|
|
388 return False;
|
|
|
389 end if;
|
|
|
390 end if;
|
|
|
391 end End_Of_File;
|
|
|
392
|
|
|
393 -------------------
|
|
|
394 -- Errno_Message --
|
|
|
395 -------------------
|
|
|
396
|
|
|
397 function Errno_Message
|
|
|
398 (Name : String;
|
|
|
399 Errno : Integer := OS_Lib.Errno) return String
|
|
|
400 is
|
|
|
401 begin
|
|
|
402 return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
|
|
|
403 end Errno_Message;
|
|
|
404
|
|
|
405 --------------
|
|
|
406 -- Finalize --
|
|
|
407 --------------
|
|
|
408
|
|
|
409 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
|
|
|
410 pragma Warnings (Off, V);
|
|
|
411
|
|
|
412 Fptr1 : aliased AFCB_Ptr;
|
|
|
413 Fptr2 : AFCB_Ptr;
|
|
|
414
|
|
|
415 Discard : int;
|
|
|
416
|
|
|
417 begin
|
|
|
418 -- Take a lock to protect global Open_Files data structure
|
|
|
419
|
|
|
420 SSL.Lock_Task.all;
|
|
|
421
|
|
|
422 -- First close all open files (the slightly complex form of this loop is
|
|
|
423 -- required because Close nulls out its argument).
|
|
|
424
|
|
|
425 Fptr1 := Open_Files;
|
|
|
426 while Fptr1 /= null loop
|
|
|
427 Fptr2 := Fptr1.Next;
|
|
|
428 Close (Fptr1'Access);
|
|
|
429 Fptr1 := Fptr2;
|
|
|
430 end loop;
|
|
|
431
|
|
|
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.
|
|
|
435
|
|
|
436 while Temp_Files /= null loop
|
|
|
437 Discard := unlink (Temp_Files.Name'Address);
|
|
|
438 Temp_Files := Temp_Files.Next;
|
|
|
439 end loop;
|
|
|
440
|
|
|
441 SSL.Unlock_Task.all;
|
|
|
442
|
|
|
443 exception
|
|
|
444 when others =>
|
|
|
445 SSL.Unlock_Task.all;
|
|
|
446 raise;
|
|
|
447 end Finalize;
|
|
|
448
|
|
|
449 -----------
|
|
|
450 -- Flush --
|
|
|
451 -----------
|
|
|
452
|
|
|
453 procedure Flush (File : AFCB_Ptr) is
|
|
|
454 begin
|
|
|
455 Check_Write_Status (File);
|
|
|
456
|
|
|
457 if fflush (File.Stream) /= 0 then
|
|
|
458 Raise_Device_Error (File);
|
|
|
459 end if;
|
|
|
460 end Flush;
|
|
|
461
|
|
|
462 ----------------
|
|
|
463 -- Fopen_Mode --
|
|
|
464 ----------------
|
|
|
465
|
|
|
466 -- The fopen mode to be used is shown by the following table:
|
|
|
467
|
|
|
468 -- OPEN CREATE
|
|
|
469 -- Append_File "r+" "w+"
|
|
|
470 -- In_File "r" "w+"
|
|
|
471 -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w"
|
|
|
472 -- Out_File (others) "w" "w"
|
|
|
473 -- Inout_File "r+" "w+"
|
|
|
474
|
|
|
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.
|
|
|
478
|
|
|
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.
|
|
|
483
|
|
|
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
|
|
|
488 -- in any case.
|
|
|
489
|
|
|
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.
|
|
|
495
|
|
|
496 -- If text file translation is required, then either "b" or "t" is appended
|
|
|
497 -- to the mode, depending on the setting of Text.
|
|
|
498
|
|
|
499 procedure Fopen_Mode
|
|
|
500 (Namestr : String;
|
|
|
501 Mode : File_Mode;
|
|
|
502 Text : Boolean;
|
|
|
503 Creat : Boolean;
|
|
|
504 Amethod : Character;
|
|
|
505 Fopstr : out Fopen_String)
|
|
|
506 is
|
|
|
507 Fptr : Positive;
|
|
|
508
|
|
|
509 function is_fifo (Path : Address) return Integer;
|
|
|
510 pragma Import (C, is_fifo, "__gnat_is_fifo");
|
|
|
511
|
|
|
512 begin
|
|
|
513 case Mode is
|
|
|
514 when In_File =>
|
|
|
515 if Creat then
|
|
|
516 Fopstr (1) := 'w';
|
|
|
517 Fopstr (2) := '+';
|
|
|
518 Fptr := 3;
|
|
|
519 else
|
|
|
520 Fopstr (1) := 'r';
|
|
|
521 Fptr := 2;
|
|
|
522 end if;
|
|
|
523
|
|
|
524 when Out_File =>
|
|
|
525 if Amethod in 'D' | 'S'
|
|
|
526 and then not Creat
|
|
|
527 and then is_fifo (Namestr'Address) = 0
|
|
|
528 then
|
|
|
529 Fopstr (1) := 'r';
|
|
|
530 Fopstr (2) := '+';
|
|
|
531 Fptr := 3;
|
|
|
532 else
|
|
|
533 Fopstr (1) := 'w';
|
|
|
534 Fptr := 2;
|
|
|
535 end if;
|
|
|
536
|
|
|
537 when Append_File
|
|
|
538 | Inout_File
|
|
|
539 =>
|
|
|
540 Fopstr (1) := (if Creat then 'w' else 'r');
|
|
|
541 Fopstr (2) := '+';
|
|
|
542 Fptr := 3;
|
|
|
543 end case;
|
|
|
544
|
|
|
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.
|
|
|
547
|
|
|
548 if text_translation_required then
|
|
|
549 Fopstr (Fptr) := (if Text then 't' else 'b');
|
|
|
550 Fptr := Fptr + 1;
|
|
|
551 end if;
|
|
|
552
|
|
|
553 Fopstr (Fptr) := ASCII.NUL;
|
|
|
554 end Fopen_Mode;
|
|
|
555
|
|
|
556 ----------
|
|
|
557 -- Form --
|
|
|
558 ----------
|
|
|
559
|
|
|
560 function Form (File : AFCB_Ptr) return String is
|
|
|
561 begin
|
|
|
562 if File = null then
|
|
|
563 raise Status_Error with "Form: file not open";
|
|
|
564 else
|
|
|
565 return File.Form.all (1 .. File.Form'Length - 1);
|
|
|
566 end if;
|
|
|
567 end Form;
|
|
|
568
|
|
|
569 ------------------
|
|
|
570 -- Form_Boolean --
|
|
|
571 ------------------
|
|
|
572
|
|
|
573 function Form_Boolean
|
|
|
574 (Form : String;
|
|
|
575 Keyword : String;
|
|
|
576 Default : Boolean) return Boolean
|
|
|
577 is
|
|
|
578 V1, V2 : Natural;
|
|
|
579 pragma Unreferenced (V2);
|
|
|
580
|
|
|
581 begin
|
|
|
582 Form_Parameter (Form, Keyword, V1, V2);
|
|
|
583
|
|
|
584 if V1 = 0 then
|
|
|
585 return Default;
|
|
|
586 elsif Form (V1) = 'y' then
|
|
|
587 return True;
|
|
|
588 elsif Form (V1) = 'n' then
|
|
|
589 return False;
|
|
|
590 else
|
|
|
591 raise Use_Error with "invalid Form";
|
|
|
592 end if;
|
|
|
593 end Form_Boolean;
|
|
|
594
|
|
|
595 ------------------
|
|
|
596 -- Form_Integer --
|
|
|
597 ------------------
|
|
|
598
|
|
|
599 function Form_Integer
|
|
|
600 (Form : String;
|
|
|
601 Keyword : String;
|
|
|
602 Default : Integer) return Integer
|
|
|
603 is
|
|
|
604 V1, V2 : Natural;
|
|
|
605 V : Integer;
|
|
|
606
|
|
|
607 begin
|
|
|
608 Form_Parameter (Form, Keyword, V1, V2);
|
|
|
609
|
|
|
610 if V1 = 0 then
|
|
|
611 return Default;
|
|
|
612
|
|
|
613 else
|
|
|
614 V := 0;
|
|
|
615
|
|
|
616 for J in V1 .. V2 loop
|
|
|
617 if Form (J) not in '0' .. '9' then
|
|
|
618 raise Use_Error with "invalid Form";
|
|
|
619 else
|
|
|
620 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
|
|
|
621 end if;
|
|
|
622
|
|
|
623 if V > 999_999 then
|
|
|
624 raise Use_Error with "invalid Form";
|
|
|
625 end if;
|
|
|
626 end loop;
|
|
|
627
|
|
|
628 return V;
|
|
|
629 end if;
|
|
|
630 end Form_Integer;
|
|
|
631
|
|
|
632 --------------------
|
|
|
633 -- Form_Parameter --
|
|
|
634 --------------------
|
|
|
635
|
|
|
636 procedure Form_Parameter
|
|
|
637 (Form : String;
|
|
|
638 Keyword : String;
|
|
|
639 Start : out Natural;
|
|
|
640 Stop : out Natural)
|
|
|
641 is
|
|
|
642 Klen : constant Integer := Keyword'Length;
|
|
|
643
|
|
|
644 begin
|
|
|
645 for J in Form'First + Klen .. Form'Last - 1 loop
|
|
|
646 if Form (J) = '='
|
|
|
647 and then Form (J - Klen .. J - 1) = Keyword
|
|
|
648 then
|
|
|
649 Start := J + 1;
|
|
|
650 Stop := Start - 1;
|
|
|
651 while Form (Stop + 1) /= ASCII.NUL
|
|
|
652 and then Form (Stop + 1) /= ','
|
|
|
653 loop
|
|
|
654 Stop := Stop + 1;
|
|
|
655 end loop;
|
|
|
656
|
|
|
657 return;
|
|
|
658 end if;
|
|
|
659 end loop;
|
|
|
660
|
|
|
661 Start := 0;
|
|
|
662 Stop := 0;
|
|
|
663 end Form_Parameter;
|
|
|
664
|
|
|
665 -------------
|
|
|
666 -- Is_Open --
|
|
|
667 -------------
|
|
|
668
|
|
|
669 function Is_Open (File : AFCB_Ptr) return Boolean is
|
|
|
670 begin
|
|
|
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.
|
|
|
676
|
|
|
677 return File /= null and then fileno (File.Stream) /= -1;
|
|
|
678 end Is_Open;
|
|
|
679
|
|
|
680 -------------------
|
|
|
681 -- Make_Buffered --
|
|
|
682 -------------------
|
|
|
683
|
|
|
684 procedure Make_Buffered
|
|
|
685 (File : AFCB_Ptr;
|
|
|
686 Buf_Siz : Interfaces.C_Streams.size_t)
|
|
|
687 is
|
|
|
688 status : Integer;
|
|
|
689 pragma Unreferenced (status);
|
|
|
690
|
|
|
691 begin
|
|
|
692 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
|
|
|
693 end Make_Buffered;
|
|
|
694
|
|
|
695 ------------------------
|
|
|
696 -- Make_Line_Buffered --
|
|
|
697 ------------------------
|
|
|
698
|
|
|
699 procedure Make_Line_Buffered
|
|
|
700 (File : AFCB_Ptr;
|
|
|
701 Line_Siz : Interfaces.C_Streams.size_t)
|
|
|
702 is
|
|
|
703 status : Integer;
|
|
|
704 pragma Unreferenced (status);
|
|
|
705
|
|
|
706 begin
|
|
|
707 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
|
|
|
708 -- No error checking???
|
|
|
709 end Make_Line_Buffered;
|
|
|
710
|
|
|
711 ---------------------
|
|
|
712 -- Make_Unbuffered --
|
|
|
713 ---------------------
|
|
|
714
|
|
|
715 procedure Make_Unbuffered (File : AFCB_Ptr) is
|
|
|
716 status : Integer;
|
|
|
717 pragma Unreferenced (status);
|
|
|
718
|
|
|
719 begin
|
|
|
720 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
|
|
|
721 -- No error checking???
|
|
|
722 end Make_Unbuffered;
|
|
|
723
|
|
|
724 ----------
|
|
|
725 -- Mode --
|
|
|
726 ----------
|
|
|
727
|
|
|
728 function Mode (File : AFCB_Ptr) return File_Mode is
|
|
|
729 begin
|
|
|
730 if File = null then
|
|
|
731 raise Status_Error with "Mode: file not open";
|
|
|
732 else
|
|
|
733 return File.Mode;
|
|
|
734 end if;
|
|
|
735 end Mode;
|
|
|
736
|
|
|
737 ----------
|
|
|
738 -- Name --
|
|
|
739 ----------
|
|
|
740
|
|
|
741 function Name (File : AFCB_Ptr) return String is
|
|
|
742 begin
|
|
|
743 if File = null then
|
|
|
744 raise Status_Error with "Name: file not open";
|
|
|
745 else
|
|
|
746 return File.Name.all (1 .. File.Name'Length - 1);
|
|
|
747 end if;
|
|
|
748 end Name;
|
|
|
749
|
|
|
750 ----------
|
|
|
751 -- Open --
|
|
|
752 ----------
|
|
|
753
|
|
|
754 procedure Open
|
|
|
755 (File_Ptr : in out AFCB_Ptr;
|
|
|
756 Dummy_FCB : AFCB'Class;
|
|
|
757 Mode : File_Mode;
|
|
|
758 Name : String;
|
|
|
759 Form : String;
|
|
|
760 Amethod : Character;
|
|
|
761 Creat : Boolean;
|
|
|
762 Text : Boolean;
|
|
|
763 C_Stream : FILEs := NULL_Stream)
|
|
|
764 is
|
|
|
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.
|
|
|
768
|
|
|
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
|
|
|
772
|
|
|
773 function Get_Case_Sensitive return Integer;
|
|
|
774 pragma Import (C, Get_Case_Sensitive,
|
|
|
775 "__gnat_get_file_names_case_sensitive");
|
|
|
776
|
|
|
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.
|
|
|
781
|
|
|
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
|
|
|
787 -- library level.
|
|
|
788
|
|
|
789 Stream : FILEs := C_Stream;
|
|
|
790 -- Stream which we open in response to this request
|
|
|
791
|
|
|
792 Shared : Shared_Status_Type;
|
|
|
793 -- Setting of Shared_Status field for file
|
|
|
794
|
|
|
795 Fopstr : aliased Fopen_String;
|
|
|
796 -- Mode string used in fopen call
|
|
|
797
|
|
|
798 Formstr : aliased String (1 .. Form'Length + 1);
|
|
|
799 -- Form string with ASCII.NUL appended, folded to lower case
|
|
|
800
|
|
|
801 Text_Encoding : Content_Encoding;
|
|
|
802
|
|
|
803 Tempfile : constant Boolean := Name = "";
|
|
|
804 -- Indicates temporary file case, which is indicated by an empty file
|
|
|
805 -- name.
|
|
|
806
|
|
|
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.
|
|
|
811
|
|
|
812 Namestr : aliased String (1 .. Namelen + 1);
|
|
|
813 -- Name as given or temporary file name with ASCII.NUL appended
|
|
|
814
|
|
|
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.
|
|
|
818
|
|
|
819 Full_Name_Len : Integer;
|
|
|
820 -- Length of name actually stored in Fullname
|
|
|
821
|
|
|
822 Encoding : CRTL.Filename_Encoding;
|
|
|
823 -- Filename encoding specified into the form parameter
|
|
|
824
|
|
|
825 -----------------
|
|
|
826 -- Record_AFCB --
|
|
|
827 -----------------
|
|
|
828
|
|
|
829 procedure Record_AFCB is
|
|
|
830 begin
|
|
|
831 File_Ptr := AFCB_Allocate (Dummy_FCB);
|
|
|
832
|
|
|
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).
|
|
|
835
|
|
|
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;
|
|
|
848
|
|
|
849 Chain_File (File_Ptr);
|
|
|
850 Append_Set (File_Ptr);
|
|
|
851 end Record_AFCB;
|
|
|
852
|
|
|
853 -- Start of processing for Open
|
|
|
854
|
|
|
855 begin
|
|
|
856 if File_Ptr /= null then
|
|
|
857 raise Status_Error with "file already open";
|
|
|
858 end if;
|
|
|
859
|
|
|
860 -- Acquire form string, setting required NUL terminator
|
|
|
861
|
|
|
862 Formstr (1 .. Form'Length) := Form;
|
|
|
863 Formstr (Formstr'Last) := ASCII.NUL;
|
|
|
864
|
|
|
865 -- Convert form string to lower case
|
|
|
866
|
|
|
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);
|
|
|
870 end if;
|
|
|
871 end loop;
|
|
|
872
|
|
|
873 -- Acquire setting of shared parameter
|
|
|
874
|
|
|
875 declare
|
|
|
876 V1, V2 : Natural;
|
|
|
877
|
|
|
878 begin
|
|
|
879 Form_Parameter (Formstr, "shared", V1, V2);
|
|
|
880
|
|
|
881 if V1 = 0 then
|
|
|
882 Shared := None;
|
|
|
883 elsif Formstr (V1 .. V2) = "yes" then
|
|
|
884 Shared := Yes;
|
|
|
885 elsif Formstr (V1 .. V2) = "no" then
|
|
|
886 Shared := No;
|
|
|
887 else
|
|
|
888 raise Use_Error with "invalid Form";
|
|
|
889 end if;
|
|
|
890 end;
|
|
|
891
|
|
|
892 -- Acquire setting of encoding parameter
|
|
|
893
|
|
|
894 declare
|
|
|
895 V1, V2 : Natural;
|
|
|
896
|
|
|
897 begin
|
|
|
898 Form_Parameter (Formstr, "encoding", V1, V2);
|
|
|
899
|
|
|
900 if V1 = 0 then
|
|
|
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;
|
|
|
906 else
|
|
|
907 raise Use_Error with "invalid Form";
|
|
|
908 end if;
|
|
|
909 end;
|
|
|
910
|
|
|
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.
|
|
|
915
|
|
|
916 if Text then
|
|
|
917 Text_Encoding := Default_Text;
|
|
|
918 else
|
|
|
919 Text_Encoding := None;
|
|
|
920 end if;
|
|
|
921
|
|
|
922 if Text_Encoding in Text_Content_Encoding then
|
|
|
923 declare
|
|
|
924 V1, V2 : Natural;
|
|
|
925
|
|
|
926 begin
|
|
|
927 Form_Parameter (Formstr, "text_translation", V1, V2);
|
|
|
928
|
|
|
929 if V1 = 0 then
|
|
|
930 null;
|
|
|
931 elsif Formstr (V1 .. V2) = "no" then
|
|
|
932 Text_Encoding := None;
|
|
|
933 elsif Formstr (V1 .. V2) = "text"
|
|
|
934 or else Formstr (V1 .. V2) = "yes"
|
|
|
935 then
|
|
|
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;
|
|
|
943 else
|
|
|
944 raise Use_Error with "invalid Form";
|
|
|
945 end if;
|
|
|
946 end;
|
|
|
947 end if;
|
|
|
948
|
|
|
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.
|
|
|
951
|
|
|
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;
|
|
|
956
|
|
|
957 -- Normal case of Open or Create
|
|
|
958
|
|
|
959 else
|
|
|
960 -- If temporary file case, get temporary file name and add to the
|
|
|
961 -- list of temporary files to be deleted on exit.
|
|
|
962
|
|
|
963 if Tempfile then
|
|
|
964 if not Creat then
|
|
|
965 raise Name_Error with "opening temp file without creating it";
|
|
|
966 end if;
|
|
|
967
|
|
|
968 Tmp_Name (Namestr'Address);
|
|
|
969
|
|
|
970 if Namestr (1) = ASCII.NUL then
|
|
|
971 raise Use_Error with "invalid temp file name";
|
|
|
972 end if;
|
|
|
973
|
|
|
974 -- Normal case of non-empty name given (i.e. not a temp file)
|
|
|
975
|
|
|
976 else
|
|
|
977 if Name'Length > Namelen then
|
|
|
978 raise Name_Error with "file name too long";
|
|
|
979 end if;
|
|
|
980
|
|
|
981 Namestr (1 .. Name'Length) := Name;
|
|
|
982 Namestr (Name'Length + 1) := ASCII.NUL;
|
|
|
983 end if;
|
|
|
984
|
|
|
985 -- Get full name in accordance with the advice of RM A.8.2(22)
|
|
|
986
|
|
|
987 full_name (Namestr'Address, Fullname'Address);
|
|
|
988
|
|
|
989 if Fullname (1) = ASCII.NUL then
|
|
|
990 raise Use_Error with Errno_Message (Name);
|
|
|
991 end if;
|
|
|
992
|
|
|
993 Full_Name_Len := 1;
|
|
|
994 while Full_Name_Len < Fullname'Last
|
|
|
995 and then Fullname (Full_Name_Len) /= ASCII.NUL
|
|
|
996 loop
|
|
|
997 Full_Name_Len := Full_Name_Len + 1;
|
|
|
998 end loop;
|
|
|
999
|
|
|
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.
|
|
|
1006
|
|
|
1007 if not File_Names_Case_Sensitive then
|
|
|
1008 To_Lower (Fullname (1 .. Full_Name_Len));
|
|
|
1009 end if;
|
|
|
1010
|
|
|
1011 -- If Shared=None or Shared=Yes, then check for the existence of
|
|
|
1012 -- another file with exactly the same full name.
|
|
|
1013
|
|
|
1014 if Shared /= No then
|
|
|
1015 declare
|
|
|
1016 P : AFCB_Ptr;
|
|
|
1017
|
|
|
1018 begin
|
|
|
1019 -- Take a task lock to protect Open_Files
|
|
|
1020
|
|
|
1021 SSL.Lock_Task.all;
|
|
|
1022
|
|
|
1023 -- Search list of open files
|
|
|
1024
|
|
|
1025 P := Open_Files;
|
|
|
1026 while P /= null loop
|
|
|
1027 if Fullname (1 .. Full_Name_Len) = P.Name.all then
|
|
|
1028
|
|
|
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.
|
|
|
1033
|
|
|
1034 if Shared = None
|
|
|
1035 or else P.Shared_Status = None
|
|
|
1036 then
|
|
|
1037 raise Use_Error with "reopening shared file";
|
|
|
1038
|
|
|
1039 -- If both files have Shared=Yes, then we acquire the
|
|
|
1040 -- stream from the located file to use as our stream.
|
|
|
1041
|
|
|
1042 elsif Shared = Yes
|
|
|
1043 and then P.Shared_Status = Yes
|
|
|
1044 then
|
|
|
1045 Stream := P.Stream;
|
|
|
1046
|
|
|
1047 Record_AFCB;
|
|
|
1048 pragma Assert (not Tempfile);
|
|
|
1049
|
|
|
1050 exit;
|
|
|
1051
|
|
|
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.
|
|
|
1058
|
|
|
1059 else
|
|
|
1060 null;
|
|
|
1061 end if;
|
|
|
1062 end if;
|
|
|
1063
|
|
|
1064 P := P.Next;
|
|
|
1065 end loop;
|
|
|
1066
|
|
|
1067 SSL.Unlock_Task.all;
|
|
|
1068
|
|
|
1069 exception
|
|
|
1070 when others =>
|
|
|
1071 SSL.Unlock_Task.all;
|
|
|
1072 raise;
|
|
|
1073 end;
|
|
|
1074 end if;
|
|
|
1075
|
|
|
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.
|
|
|
1078
|
|
|
1079 if Stream /= NULL_Stream then
|
|
|
1080 return;
|
|
|
1081
|
|
|
1082 else
|
|
|
1083 Fopen_Mode
|
|
|
1084 (Namestr => Namestr,
|
|
|
1085 Mode => Mode,
|
|
|
1086 Text => Text_Encoding in Text_Content_Encoding,
|
|
|
1087 Creat => Creat,
|
|
|
1088 Amethod => Amethod,
|
|
|
1089 Fopstr => Fopstr);
|
|
|
1090
|
|
|
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.
|
|
|
1094
|
|
|
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);
|
|
|
1098 end if;
|
|
|
1099 end if;
|
|
|
1100
|
|
|
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.
|
|
|
1106
|
|
|
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.
|
|
|
1110
|
|
|
1111 Stream :=
|
|
|
1112 fopen (Namestr'Address, Fopstr'Address, Encoding);
|
|
|
1113
|
|
|
1114 if Stream = NULL_Stream then
|
|
|
1115
|
|
|
1116 -- Raise Name_Error if trying to open a non-existent file.
|
|
|
1117 -- Otherwise raise Use_Error.
|
|
|
1118
|
|
|
1119 -- Should we raise Device_Error for ENOSPC???
|
|
|
1120
|
|
|
1121 declare
|
|
|
1122 function Is_File_Not_Found_Error
|
|
|
1123 (Errno_Value : Integer) return Integer;
|
|
|
1124 pragma Import
|
|
|
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-
|
|
|
1128 -- existing file.
|
|
|
1129
|
|
|
1130 Errno : constant Integer := OS_Lib.Errno;
|
|
|
1131 Message : constant String := Errno_Message (Name, Errno);
|
|
|
1132
|
|
|
1133 begin
|
|
|
1134 if Is_File_Not_Found_Error (Errno) /= 0 then
|
|
|
1135 raise Name_Error with Message;
|
|
|
1136 else
|
|
|
1137 raise Use_Error with Message;
|
|
|
1138 end if;
|
|
|
1139 end;
|
|
|
1140 end if;
|
|
|
1141 end if;
|
|
|
1142 end if;
|
|
|
1143
|
|
|
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.
|
|
|
1147
|
|
|
1148 Record_AFCB;
|
|
|
1149
|
|
|
1150 if Tempfile then
|
|
|
1151 -- Chain to temp file list, ensuring thread safety with a lock
|
|
|
1152
|
|
|
1153 begin
|
|
|
1154 SSL.Lock_Task.all;
|
|
|
1155 Temp_Files :=
|
|
|
1156 new Temp_File_Record'
|
|
|
1157 (File => File_Ptr, Name => Namestr, Next => Temp_Files);
|
|
|
1158 SSL.Unlock_Task.all;
|
|
|
1159
|
|
|
1160 exception
|
|
|
1161 when others =>
|
|
|
1162 SSL.Unlock_Task.all;
|
|
|
1163 raise;
|
|
|
1164 end;
|
|
|
1165 end if;
|
|
|
1166 end Open;
|
|
|
1167
|
|
|
1168 ------------------------
|
|
|
1169 -- Raise_Device_Error --
|
|
|
1170 ------------------------
|
|
|
1171
|
|
|
1172 procedure Raise_Device_Error
|
|
|
1173 (File : AFCB_Ptr;
|
|
|
1174 Errno : Integer := OS_Lib.Errno)
|
|
|
1175 is
|
|
|
1176 begin
|
|
|
1177 -- Clear error status so that the same error is not reported twice
|
|
|
1178
|
|
|
1179 if File /= null then
|
|
|
1180 clearerr (File.Stream);
|
|
|
1181 end if;
|
|
|
1182
|
|
|
1183 raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
|
|
|
1184 end Raise_Device_Error;
|
|
|
1185
|
|
|
1186 --------------
|
|
|
1187 -- Read_Buf --
|
|
|
1188 --------------
|
|
|
1189
|
|
|
1190 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
|
|
|
1191 Nread : size_t;
|
|
|
1192
|
|
|
1193 begin
|
|
|
1194 Nread := fread (Buf, 1, Siz, File.Stream);
|
|
|
1195
|
|
|
1196 if Nread = Siz then
|
|
|
1197 return;
|
|
|
1198
|
|
|
1199 elsif ferror (File.Stream) /= 0 then
|
|
|
1200 Raise_Device_Error (File);
|
|
|
1201
|
|
|
1202 elsif Nread = 0 then
|
|
|
1203 raise End_Error;
|
|
|
1204
|
|
|
1205 else -- 0 < Nread < Siz
|
|
|
1206 raise Data_Error with "not enough data read";
|
|
|
1207 end if;
|
|
|
1208 end Read_Buf;
|
|
|
1209
|
|
|
1210 procedure Read_Buf
|
|
|
1211 (File : AFCB_Ptr;
|
|
|
1212 Buf : Address;
|
|
|
1213 Siz : Interfaces.C_Streams.size_t;
|
|
|
1214 Count : out Interfaces.C_Streams.size_t)
|
|
|
1215 is
|
|
|
1216 begin
|
|
|
1217 Count := fread (Buf, 1, Siz, File.Stream);
|
|
|
1218
|
|
|
1219 if Count = 0 and then ferror (File.Stream) /= 0 then
|
|
|
1220 Raise_Device_Error (File);
|
|
|
1221 end if;
|
|
|
1222 end Read_Buf;
|
|
|
1223
|
|
|
1224 -----------
|
|
|
1225 -- Reset --
|
|
|
1226 -----------
|
|
|
1227
|
|
|
1228 -- The reset which does not change the mode simply does a rewind
|
|
|
1229
|
|
|
1230 procedure Reset (File_Ptr : access AFCB_Ptr) is
|
|
|
1231 File : AFCB_Ptr renames File_Ptr.all;
|
|
|
1232 begin
|
|
|
1233 Check_File_Open (File);
|
|
|
1234 Reset (File_Ptr, File.Mode);
|
|
|
1235 end Reset;
|
|
|
1236
|
|
|
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).
|
|
|
1240
|
|
|
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;
|
|
|
1244
|
|
|
1245 begin
|
|
|
1246 Check_File_Open (File);
|
|
|
1247
|
|
|
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.
|
|
|
1251
|
|
|
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";
|
|
|
1261 end if;
|
|
|
1262 end if;
|
|
|
1263
|
|
|
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
|
|
|
1266 -- reopen.
|
|
|
1267
|
|
|
1268 if Mode = File.Mode
|
|
|
1269 and then Mode in Read_File_Mode
|
|
|
1270 then
|
|
|
1271 rewind (File.Stream);
|
|
|
1272
|
|
|
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.
|
|
|
1275
|
|
|
1276 else
|
|
|
1277 Fopen_Mode
|
|
|
1278 (Namestr => File.Name.all,
|
|
|
1279 Mode => Mode,
|
|
|
1280 Text => File.Text_Encoding in Text_Content_Encoding,
|
|
|
1281 Creat => False,
|
|
|
1282 Amethod => File.Access_Method,
|
|
|
1283 Fopstr => Fopstr);
|
|
|
1284
|
|
|
1285 File.Stream := freopen
|
|
|
1286 (File.Name.all'Address, Fopstr'Address, File.Stream,
|
|
|
1287 File.Encoding);
|
|
|
1288
|
|
|
1289 if File.Stream = NULL_Stream then
|
|
|
1290 Close (File_Ptr);
|
|
|
1291 raise Use_Error;
|
|
|
1292 else
|
|
|
1293 File.Mode := Mode;
|
|
|
1294 Append_Set (File);
|
|
|
1295 end if;
|
|
|
1296 end if;
|
|
|
1297 end Reset;
|
|
|
1298
|
|
|
1299 ---------------
|
|
|
1300 -- Write_Buf --
|
|
|
1301 ---------------
|
|
|
1302
|
|
|
1303 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
|
|
|
1304 begin
|
|
|
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.
|
|
|
1309
|
|
|
1310 SSL.Abort_Defer.all;
|
|
|
1311
|
|
|
1312 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
|
|
|
1313 if Siz /= 0 then
|
|
|
1314 SSL.Abort_Undefer.all;
|
|
|
1315 Raise_Device_Error (File);
|
|
|
1316 end if;
|
|
|
1317 end if;
|
|
|
1318
|
|
|
1319 SSL.Abort_Undefer.all;
|
|
|
1320 end Write_Buf;
|
|
|
1321
|
|
|
1322 end System.File_IO;
|
