S/390: Add static OSC breaker if necessary.
[official-gcc.git] / gcc / ada / s-fileio.adb
blobb8bc1ad2248d8dc595857ad829200b5a641da93b
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 -- --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
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 ------------------------------------------------------------------------------
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;
37 with Interfaces.C_Streams; use Interfaces.C_Streams;
39 with System.Case_Util; use System.Case_Util;
40 with System.CRTL;
41 with System.OS_Lib;
42 with System.Soft_Links;
44 package body System.File_IO is
46 use System.File_Control_Block;
48 package SSL renames System.Soft_Links;
50 use type CRTL.size_t;
51 use type Interfaces.C.int;
53 ----------------------
54 -- Global Variables --
55 ----------------------
57 Open_Files : AFCB_Ptr;
58 -- This points to a list of AFCB's for all open files. This is a doubly
59 -- linked list, with the Prev pointer of the first entry, and the Next
60 -- pointer of the last entry containing null. Note that this global
61 -- variable must be properly protected to provide thread safety.
63 type Temp_File_Record;
64 type Temp_File_Record_Ptr is access all Temp_File_Record;
66 type Temp_File_Record is record
67 Name : String (1 .. max_path_len + 1);
68 Next : Temp_File_Record_Ptr;
69 end record;
70 -- One of these is allocated for each temporary file created
72 Temp_Files : Temp_File_Record_Ptr;
73 -- Points to list of names of temporary files. Note that this global
74 -- variable must be properly protected to provide thread safety.
76 type File_IO_Clean_Up_Type is new Limited_Controlled with null record;
77 -- The closing of all open files and deletion of temporary files is an
78 -- action that takes place at the end of execution of the main program.
79 -- This action is implemented using a library level object which gets
80 -- finalized at the end of program execution. Note that the type is
81 -- limited, in order to stop the compiler optimizing away the declaration
82 -- which would be allowed in the non-limited case.
84 procedure Finalize (V : in out File_IO_Clean_Up_Type);
85 -- This is the finalize operation that is used to do the cleanup
87 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
88 pragma Warnings (Off, File_IO_Clean_Up_Object);
89 -- This is the single object of the type that triggers the finalization
90 -- call. Since it is at the library level, this happens just before the
91 -- environment task is finalized.
93 text_translation_required : Boolean;
94 for text_translation_required'Size use Character'Size;
95 pragma Import
96 (C, text_translation_required, "__gnat_text_translation_required");
97 -- If true, add appropriate suffix to control string for Open
99 -----------------------
100 -- Local Subprograms --
101 -----------------------
103 procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
105 subtype Fopen_String is String (1 .. 4);
106 -- Holds open string (longest is "w+b" & nul)
108 procedure Fopen_Mode
109 (Namestr : String;
110 Mode : File_Mode;
111 Text : Boolean;
112 Creat : Boolean;
113 Amethod : Character;
114 Fopstr : out Fopen_String);
115 -- Determines proper open mode for a file to be opened in the given Ada
116 -- mode. Namestr is the NUL-terminated file name. Text is true for a text
117 -- file and false otherwise, and Creat is true for a create call, and False
118 -- for an open call. The value stored in Fopstr is a nul-terminated string
119 -- suitable for a call to fopen or freopen. Amethod is the character
120 -- designating the access method from the Access_Method field of the FCB.
122 function Errno_Message
123 (Name : String;
124 Errno : Integer := OS_Lib.Errno) return String;
125 -- Return Errno_Message for Errno, with file name prepended
127 procedure Raise_Device_Error
128 (File : AFCB_Ptr;
129 Errno : Integer := OS_Lib.Errno);
130 pragma No_Return (Raise_Device_Error);
131 -- Clear error indication on File and raise Device_Error with an exception
132 -- message providing errno information.
134 ----------------
135 -- Append_Set --
136 ----------------
138 procedure Append_Set (File : AFCB_Ptr) is
139 begin
140 if File.Mode = Append_File then
141 if fseek (File.Stream, 0, SEEK_END) /= 0 then
142 Raise_Device_Error (File);
143 end if;
144 end if;
145 end Append_Set;
147 ----------------
148 -- Chain_File --
149 ----------------
151 procedure Chain_File (File : AFCB_Ptr) is
152 begin
153 -- Take a task lock, to protect the global data value Open_Files
155 SSL.Lock_Task.all;
157 -- Do the chaining operation locked
159 File.Next := Open_Files;
160 File.Prev := null;
161 Open_Files := File;
163 if File.Next /= null then
164 File.Next.Prev := File;
165 end if;
167 SSL.Unlock_Task.all;
169 exception
170 when others =>
171 SSL.Unlock_Task.all;
172 raise;
173 end Chain_File;
175 ---------------------
176 -- Check_File_Open --
177 ---------------------
179 procedure Check_File_Open (File : AFCB_Ptr) is
180 begin
181 if File = null then
182 raise Status_Error with "file not open";
183 end if;
184 end Check_File_Open;
186 -----------------------
187 -- Check_Read_Status --
188 -----------------------
190 procedure Check_Read_Status (File : AFCB_Ptr) is
191 begin
192 if File = null then
193 raise Status_Error with "file not open";
194 elsif File.Mode not in Read_File_Mode then
195 raise Mode_Error with "file not readable";
196 end if;
197 end Check_Read_Status;
199 ------------------------
200 -- Check_Write_Status --
201 ------------------------
203 procedure Check_Write_Status (File : AFCB_Ptr) is
204 begin
205 if File = null then
206 raise Status_Error with "file not open";
207 elsif File.Mode = In_File then
208 raise Mode_Error with "file not writable";
209 end if;
210 end Check_Write_Status;
212 -----------
213 -- Close --
214 -----------
216 procedure Close (File_Ptr : access AFCB_Ptr) is
217 Close_Status : int := 0;
218 Dup_Strm : Boolean := False;
219 Errno : Integer := 0;
221 File : AFCB_Ptr renames File_Ptr.all;
223 begin
224 -- Take a task lock, to protect the global data value Open_Files
226 SSL.Lock_Task.all;
228 Check_File_Open (File);
229 AFCB_Close (File);
231 -- Sever the association between the given file and its associated
232 -- external file. The given file is left closed. Do not perform system
233 -- closes on the standard input, output and error files and also do not
234 -- attempt to close a stream that does not exist (signalled by a null
235 -- stream value -- happens in some error situations).
237 if not File.Is_System_File and then File.Stream /= NULL_Stream then
239 -- Do not do an fclose if this is a shared file and there is at least
240 -- one other instance of the stream that is open.
242 if File.Shared_Status = Yes then
243 declare
244 P : AFCB_Ptr;
246 begin
247 P := Open_Files;
248 while P /= null loop
249 if P /= File and then File.Stream = P.Stream then
250 Dup_Strm := True;
251 exit;
252 end if;
254 P := P.Next;
255 end loop;
256 end;
257 end if;
259 -- Do the fclose unless this was a duplicate in the shared case
261 if not Dup_Strm then
262 Close_Status := fclose (File.Stream);
264 if Close_Status /= 0 then
265 Errno := OS_Lib.Errno;
266 end if;
267 end if;
268 end if;
270 -- Dechain file from list of open files and then free the storage
272 if File.Prev = null then
273 Open_Files := File.Next;
274 else
275 File.Prev.Next := File.Next;
276 end if;
278 if File.Next /= null then
279 File.Next.Prev := File.Prev;
280 end if;
282 -- Deallocate some parts of the file structure that were kept in heap
283 -- storage with the exception of system files (standard input, output
284 -- and error) since they had some information allocated in the stack.
286 if not File.Is_System_File then
287 Free_String (File.Name);
288 Free_String (File.Form);
289 AFCB_Free (File);
290 end if;
292 File := null;
294 if Close_Status /= 0 then
295 Raise_Device_Error (null, Errno);
296 end if;
298 SSL.Unlock_Task.all;
300 exception
301 when others =>
302 SSL.Unlock_Task.all;
303 raise;
304 end Close;
306 ------------
307 -- Delete --
308 ------------
310 procedure Delete (File_Ptr : access AFCB_Ptr) is
311 File : AFCB_Ptr renames File_Ptr.all;
313 begin
314 Check_File_Open (File);
316 if not File.Is_Regular_File then
317 raise Use_Error with "cannot delete non-regular file";
318 end if;
320 declare
321 Filename : aliased constant String := File.Name.all;
323 begin
324 Close (File_Ptr);
326 -- Now unlink the external file. Note that we use the full name in
327 -- this unlink, because the working directory may have changed since
328 -- we did the open, and we want to unlink the right file.
330 if unlink (Filename'Address) = -1 then
331 raise Use_Error with OS_Lib.Errno_Message;
332 end if;
333 end;
334 end Delete;
336 -----------------
337 -- End_Of_File --
338 -----------------
340 function End_Of_File (File : AFCB_Ptr) return Boolean is
341 begin
342 Check_File_Open (File);
344 if feof (File.Stream) /= 0 then
345 return True;
347 else
348 Check_Read_Status (File);
350 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
351 clearerr (File.Stream);
352 return True;
353 else
354 return False;
355 end if;
356 end if;
357 end End_Of_File;
359 -------------------
360 -- Errno_Message --
361 -------------------
363 function Errno_Message
364 (Name : String;
365 Errno : Integer := OS_Lib.Errno) return String
367 begin
368 return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
369 end Errno_Message;
371 --------------
372 -- Finalize --
373 --------------
375 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
376 pragma Warnings (Off, V);
378 Fptr1 : aliased AFCB_Ptr;
379 Fptr2 : AFCB_Ptr;
381 Discard : int;
383 begin
384 -- Take a lock to protect global Open_Files data structure
386 SSL.Lock_Task.all;
388 -- First close all open files (the slightly complex form of this loop is
389 -- required because Close as a side effect nulls out its argument).
391 Fptr1 := Open_Files;
392 while Fptr1 /= null loop
393 Fptr2 := Fptr1.Next;
394 Close (Fptr1'Access);
395 Fptr1 := Fptr2;
396 end loop;
398 -- Now unlink all temporary files. We do not bother to free the blocks
399 -- because we are just about to terminate the program. We also ignore
400 -- any errors while attempting these unlink operations.
402 while Temp_Files /= null loop
403 Discard := unlink (Temp_Files.Name'Address);
404 Temp_Files := Temp_Files.Next;
405 end loop;
407 SSL.Unlock_Task.all;
409 exception
410 when others =>
411 SSL.Unlock_Task.all;
412 raise;
413 end Finalize;
415 -----------
416 -- Flush --
417 -----------
419 procedure Flush (File : AFCB_Ptr) is
420 begin
421 Check_Write_Status (File);
423 if fflush (File.Stream) /= 0 then
424 Raise_Device_Error (File);
425 end if;
426 end Flush;
428 ----------------
429 -- Fopen_Mode --
430 ----------------
432 -- The fopen mode to be used is shown by the following table:
434 -- OPEN CREATE
435 -- Append_File "r+" "w+"
436 -- In_File "r" "w+"
437 -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w"
438 -- Out_File (others) "w" "w"
439 -- Inout_File "r+" "w+"
441 -- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a
442 -- named pipe), we use "w" instead of "r+". This is necessary to make a
443 -- write to the fifo block until a reader is ready.
445 -- Note: we do not use "a" or "a+" for Append_File, since this would not
446 -- work in the case of stream files, where even if in append file mode,
447 -- you can reset to earlier points in the file. The caller must use the
448 -- Append_Set routine to deal with the necessary positioning.
450 -- Note: in several cases, the fopen mode used allows reading and writing,
451 -- but the setting of the Ada mode is more restrictive. For instance,
452 -- Create in In_File mode uses "w+" which allows writing, but the Ada mode
453 -- In_File will cause any write operations to be rejected with Mode_Error
454 -- in any case.
456 -- Note: for the Out_File/Open cases for other than the Direct_IO case, an
457 -- initial call will be made by the caller to first open the file in "r"
458 -- mode to be sure that it exists. The real open, in "w" mode, will then
459 -- destroy this file. This is peculiar, but that's what Ada semantics
460 -- require and the ACATS tests insist on.
462 -- If text file translation is required, then either "b" or "t" is appended
463 -- to the mode, depending on the setting of Text.
465 procedure Fopen_Mode
466 (Namestr : String;
467 Mode : File_Mode;
468 Text : Boolean;
469 Creat : Boolean;
470 Amethod : Character;
471 Fopstr : out Fopen_String)
473 Fptr : Positive;
475 function is_fifo (Path : Address) return Integer;
476 pragma Import (C, is_fifo, "__gnat_is_fifo");
478 begin
479 case Mode is
480 when In_File =>
481 if Creat then
482 Fopstr (1) := 'w';
483 Fopstr (2) := '+';
484 Fptr := 3;
485 else
486 Fopstr (1) := 'r';
487 Fptr := 2;
488 end if;
490 when Out_File =>
491 if Amethod in 'D' | 'S'
492 and then not Creat
493 and then is_fifo (Namestr'Address) = 0
494 then
495 Fopstr (1) := 'r';
496 Fopstr (2) := '+';
497 Fptr := 3;
498 else
499 Fopstr (1) := 'w';
500 Fptr := 2;
501 end if;
503 when Inout_File | Append_File =>
504 Fopstr (1) := (if Creat then 'w' else 'r');
505 Fopstr (2) := '+';
506 Fptr := 3;
507 end case;
509 -- If text_translation_required is true then we need to append either a
510 -- "t" or "b" to the string to get the right mode.
512 if text_translation_required then
513 Fopstr (Fptr) := (if Text then 't' else 'b');
514 Fptr := Fptr + 1;
515 end if;
517 Fopstr (Fptr) := ASCII.NUL;
518 end Fopen_Mode;
520 ----------
521 -- Form --
522 ----------
524 function Form (File : AFCB_Ptr) return String is
525 begin
526 if File = null then
527 raise Status_Error with "Form: file not open";
528 else
529 return File.Form.all (1 .. File.Form'Length - 1);
530 end if;
531 end Form;
533 ------------------
534 -- Form_Boolean --
535 ------------------
537 function Form_Boolean
538 (Form : String;
539 Keyword : String;
540 Default : Boolean) return Boolean
542 V1, V2 : Natural;
543 pragma Unreferenced (V2);
545 begin
546 Form_Parameter (Form, Keyword, V1, V2);
548 if V1 = 0 then
549 return Default;
550 elsif Form (V1) = 'y' then
551 return True;
552 elsif Form (V1) = 'n' then
553 return False;
554 else
555 raise Use_Error with "invalid Form";
556 end if;
557 end Form_Boolean;
559 ------------------
560 -- Form_Integer --
561 ------------------
563 function Form_Integer
564 (Form : String;
565 Keyword : String;
566 Default : Integer) return Integer
568 V1, V2 : Natural;
569 V : Integer;
571 begin
572 Form_Parameter (Form, Keyword, V1, V2);
574 if V1 = 0 then
575 return Default;
577 else
578 V := 0;
580 for J in V1 .. V2 loop
581 if Form (J) not in '0' .. '9' then
582 raise Use_Error with "invalid Form";
583 else
584 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
585 end if;
587 if V > 999_999 then
588 raise Use_Error with "invalid Form";
589 end if;
590 end loop;
592 return V;
593 end if;
594 end Form_Integer;
596 --------------------
597 -- Form_Parameter --
598 --------------------
600 procedure Form_Parameter
601 (Form : String;
602 Keyword : String;
603 Start : out Natural;
604 Stop : out Natural)
606 Klen : constant Integer := Keyword'Length;
608 begin
609 for J in Form'First + Klen .. Form'Last - 1 loop
610 if Form (J) = '='
611 and then Form (J - Klen .. J - 1) = Keyword
612 then
613 Start := J + 1;
614 Stop := Start - 1;
615 while Form (Stop + 1) /= ASCII.NUL
616 and then Form (Stop + 1) /= ','
617 loop
618 Stop := Stop + 1;
619 end loop;
621 return;
622 end if;
623 end loop;
625 Start := 0;
626 Stop := 0;
627 end Form_Parameter;
629 -------------
630 -- Is_Open --
631 -------------
633 function Is_Open (File : AFCB_Ptr) return Boolean is
634 begin
635 -- We return True if the file is open, and the underlying file stream is
636 -- usable. In particular on Windows an application linked with -mwindows
637 -- option set does not have a console attached. In this case standard
638 -- files (Current_Output, Current_Error, Current_Input) are not created.
639 -- We want Is_Open (Current_Output) to return False in this case.
641 return File /= null and then fileno (File.Stream) /= -1;
642 end Is_Open;
644 -------------------
645 -- Make_Buffered --
646 -------------------
648 procedure Make_Buffered
649 (File : AFCB_Ptr;
650 Buf_Siz : Interfaces.C_Streams.size_t)
652 status : Integer;
653 pragma Unreferenced (status);
655 begin
656 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
657 end Make_Buffered;
659 ------------------------
660 -- Make_Line_Buffered --
661 ------------------------
663 procedure Make_Line_Buffered
664 (File : AFCB_Ptr;
665 Line_Siz : Interfaces.C_Streams.size_t)
667 status : Integer;
668 pragma Unreferenced (status);
670 begin
671 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
672 -- No error checking???
673 end Make_Line_Buffered;
675 ---------------------
676 -- Make_Unbuffered --
677 ---------------------
679 procedure Make_Unbuffered (File : AFCB_Ptr) is
680 status : Integer;
681 pragma Unreferenced (status);
683 begin
684 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
685 -- No error checking???
686 end Make_Unbuffered;
688 ----------
689 -- Mode --
690 ----------
692 function Mode (File : AFCB_Ptr) return File_Mode is
693 begin
694 if File = null then
695 raise Status_Error with "Mode: file not open";
696 else
697 return File.Mode;
698 end if;
699 end Mode;
701 ----------
702 -- Name --
703 ----------
705 function Name (File : AFCB_Ptr) return String is
706 begin
707 if File = null then
708 raise Status_Error with "Name: file not open";
709 else
710 return File.Name.all (1 .. File.Name'Length - 1);
711 end if;
712 end Name;
714 ----------
715 -- Open --
716 ----------
718 procedure Open
719 (File_Ptr : in out AFCB_Ptr;
720 Dummy_FCB : AFCB'Class;
721 Mode : File_Mode;
722 Name : String;
723 Form : String;
724 Amethod : Character;
725 Creat : Boolean;
726 Text : Boolean;
727 C_Stream : FILEs := NULL_Stream)
729 pragma Warnings (Off, Dummy_FCB);
730 -- Yes we know this is never assigned a value. That's intended, since
731 -- all we ever use of this value is the tag for dispatching purposes.
733 procedure Tmp_Name (Buffer : Address);
734 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
735 -- Set buffer (a String address) with a temporary filename
737 function Get_Case_Sensitive return Integer;
738 pragma Import (C, Get_Case_Sensitive,
739 "__gnat_get_file_names_case_sensitive");
741 procedure Record_AFCB;
742 -- Create and record new AFCB into the runtime, note that the
743 -- implementation uses the variables below which corresponds to the
744 -- status of the opened file.
746 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
747 -- Set to indicate whether the operating system convention is for file
748 -- names to be case sensitive (e.g., in Unix, set True), or not case
749 -- sensitive (e.g., in Windows, set False). Declared locally to avoid
750 -- breaking the Preelaborate rule that disallows function calls at the
751 -- library level.
753 Stream : FILEs := C_Stream;
754 -- Stream which we open in response to this request
756 Shared : Shared_Status_Type;
757 -- Setting of Shared_Status field for file
759 Fopstr : aliased Fopen_String;
760 -- Mode string used in fopen call
762 Formstr : aliased String (1 .. Form'Length + 1);
763 -- Form string with ASCII.NUL appended, folded to lower case
765 Text_Encoding : Content_Encoding;
767 Tempfile : constant Boolean := (Name'Length = 0);
768 -- Indicates temporary file case
770 Namelen : constant Integer := max_path_len;
771 -- Length required for file name, not including final ASCII.NUL.
772 -- Note that we used to reference L_tmpnam here, which is not reliable
773 -- since __gnat_tmp_name does not always use tmpnam.
775 Namestr : aliased String (1 .. Namelen + 1);
776 -- Name as given or temporary file name with ASCII.NUL appended
778 Fullname : aliased String (1 .. max_path_len + 1);
779 -- Full name (as required for Name function, and as stored in the
780 -- control block in the Name field) with ASCII.NUL appended.
782 Full_Name_Len : Integer;
783 -- Length of name actually stored in Fullname
785 Encoding : CRTL.Filename_Encoding;
786 -- Filename encoding specified into the form parameter
788 -----------------
789 -- Record_AFCB --
790 -----------------
792 procedure Record_AFCB is
793 begin
794 File_Ptr := AFCB_Allocate (Dummy_FCB);
796 -- Note that we cannot use an aggregate here as File_Ptr is a
797 -- class-wide access to a limited type (Root_Stream_Type).
799 File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0;
800 File_Ptr.Is_System_File := False;
801 File_Ptr.Text_Encoding := Text_Encoding;
802 File_Ptr.Shared_Status := Shared;
803 File_Ptr.Access_Method := Amethod;
804 File_Ptr.Stream := Stream;
805 File_Ptr.Form := new String'(Formstr);
806 File_Ptr.Name := new String'(Fullname
807 (1 .. Full_Name_Len));
808 File_Ptr.Mode := Mode;
809 File_Ptr.Is_Temporary_File := Tempfile;
810 File_Ptr.Encoding := Encoding;
812 Chain_File (File_Ptr);
813 Append_Set (File_Ptr);
814 end Record_AFCB;
816 -- Start of processing for Open
818 begin
819 if File_Ptr /= null then
820 raise Status_Error with "file already open";
821 end if;
823 -- Acquire form string, setting required NUL terminator
825 Formstr (1 .. Form'Length) := Form;
826 Formstr (Formstr'Last) := ASCII.NUL;
828 -- Convert form string to lower case
830 for J in Formstr'Range loop
831 if Formstr (J) in 'A' .. 'Z' then
832 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
833 end if;
834 end loop;
836 -- Acquire setting of shared parameter
838 declare
839 V1, V2 : Natural;
841 begin
842 Form_Parameter (Formstr, "shared", V1, V2);
844 if V1 = 0 then
845 Shared := None;
846 elsif Formstr (V1 .. V2) = "yes" then
847 Shared := Yes;
848 elsif Formstr (V1 .. V2) = "no" then
849 Shared := No;
850 else
851 raise Use_Error with "invalid Form";
852 end if;
853 end;
855 -- Acquire setting of encoding parameter
857 declare
858 V1, V2 : Natural;
860 begin
861 Form_Parameter (Formstr, "encoding", V1, V2);
863 if V1 = 0 then
864 Encoding := CRTL.Unspecified;
865 elsif Formstr (V1 .. V2) = "utf8" then
866 Encoding := CRTL.UTF8;
867 elsif Formstr (V1 .. V2) = "8bits" then
868 Encoding := CRTL.ASCII_8bits;
869 else
870 raise Use_Error with "invalid Form";
871 end if;
872 end;
874 -- Acquire setting of text_translation parameter. Only needed if this is
875 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
876 -- if the Form says Text_Translation=No, we use binary mode, so new-line
877 -- will be just LF, even on Windows.
879 if Text then
880 Text_Encoding := Default_Text;
881 else
882 Text_Encoding := None;
883 end if;
885 if Text_Encoding in Text_Content_Encoding then
886 declare
887 V1, V2 : Natural;
889 begin
890 Form_Parameter (Formstr, "text_translation", V1, V2);
892 if V1 = 0 then
893 null;
894 elsif Formstr (V1 .. V2) = "no" then
895 Text_Encoding := None;
896 elsif Formstr (V1 .. V2) = "text"
897 or else Formstr (V1 .. V2) = "yes"
898 then
899 Text_Encoding := Interfaces.C_Streams.Text;
900 elsif Formstr (V1 .. V2) = "wtext" then
901 Text_Encoding := Wtext;
902 elsif Formstr (V1 .. V2) = "u8text" then
903 Text_Encoding := U8text;
904 elsif Formstr (V1 .. V2) = "u16text" then
905 Text_Encoding := U16text;
906 else
907 raise Use_Error with "invalid Form";
908 end if;
909 end;
910 end if;
912 -- If we were given a stream (call from xxx.C_Streams.Open), then set
913 -- the full name to the given one, and skip to end of processing.
915 if Stream /= NULL_Stream then
916 Full_Name_Len := Name'Length + 1;
917 Fullname (1 .. Full_Name_Len - 1) := Name;
918 Fullname (Full_Name_Len) := ASCII.NUL;
920 -- Normal case of Open or Create
922 else
923 -- If temporary file case, get temporary file name and add to the
924 -- list of temporary files to be deleted on exit.
926 if Tempfile then
927 if not Creat then
928 raise Name_Error with "opening temp file without creating it";
929 end if;
931 Tmp_Name (Namestr'Address);
933 if Namestr (1) = ASCII.NUL then
934 raise Use_Error with "invalid temp file name";
935 end if;
937 -- Chain to temp file list, ensuring thread safety with a lock
939 begin
940 SSL.Lock_Task.all;
941 Temp_Files :=
942 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
943 SSL.Unlock_Task.all;
945 exception
946 when others =>
947 SSL.Unlock_Task.all;
948 raise;
949 end;
951 -- Normal case of non-null name given
953 else
954 if Name'Length > Namelen then
955 raise Name_Error with "file name too long";
956 end if;
958 Namestr (1 .. Name'Length) := Name;
959 Namestr (Name'Length + 1) := ASCII.NUL;
960 end if;
962 -- Get full name in accordance with the advice of RM A.8.2(22)
964 full_name (Namestr'Address, Fullname'Address);
966 if Fullname (1) = ASCII.NUL then
967 raise Use_Error with Errno_Message (Name);
968 end if;
970 Full_Name_Len := 1;
971 while Full_Name_Len < Fullname'Last
972 and then Fullname (Full_Name_Len) /= ASCII.NUL
973 loop
974 Full_Name_Len := Full_Name_Len + 1;
975 end loop;
977 -- Fullname is generated by calling system's full_name. The problem
978 -- is, full_name does nothing about the casing, so a file name
979 -- comparison may generally speaking not be valid on non-case-
980 -- sensitive systems, and in particular we get unexpected failures
981 -- on Windows/Vista because of this. So we use s-casuti to force
982 -- the name to lower case.
984 if not File_Names_Case_Sensitive then
985 To_Lower (Fullname (1 .. Full_Name_Len));
986 end if;
988 -- If Shared=None or Shared=Yes, then check for the existence of
989 -- another file with exactly the same full name.
991 if Shared /= No then
992 declare
993 P : AFCB_Ptr;
995 begin
996 -- Take a task lock to protect Open_Files
998 SSL.Lock_Task.all;
1000 -- Search list of open files
1002 P := Open_Files;
1003 while P /= null loop
1004 if Fullname (1 .. Full_Name_Len) = P.Name.all then
1006 -- If we get a match, and either file has Shared=None,
1007 -- then raise Use_Error, since we don't allow two files
1008 -- of the same name to be opened unless they specify the
1009 -- required sharing mode.
1011 if Shared = None
1012 or else P.Shared_Status = None
1013 then
1014 raise Use_Error with "reopening shared file";
1016 -- If both files have Shared=Yes, then we acquire the
1017 -- stream from the located file to use as our stream.
1019 elsif Shared = Yes
1020 and then P.Shared_Status = Yes
1021 then
1022 Stream := P.Stream;
1024 Record_AFCB;
1026 exit;
1028 -- Otherwise one of the files has Shared=Yes and one has
1029 -- Shared=No. If the current file has Shared=No then all
1030 -- is well but we don't want to share any other file's
1031 -- stream. If the current file has Shared=Yes, we would
1032 -- like to share a stream, but not from a file that has
1033 -- Shared=No, so either way, we just continue the search.
1035 else
1036 null;
1037 end if;
1038 end if;
1040 P := P.Next;
1041 end loop;
1043 SSL.Unlock_Task.all;
1045 exception
1046 when others =>
1047 SSL.Unlock_Task.all;
1048 raise;
1049 end;
1050 end if;
1052 -- Open specified file if we did not find an existing stream,
1053 -- otherwise we just return as there is nothing more to be done.
1055 if Stream /= NULL_Stream then
1056 return;
1058 else
1059 Fopen_Mode
1060 (Namestr => Namestr,
1061 Mode => Mode,
1062 Text => Text_Encoding in Text_Content_Encoding,
1063 Creat => Creat,
1064 Amethod => Amethod,
1065 Fopstr => Fopstr);
1067 -- A special case, if we are opening (OPEN case) a file and the
1068 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
1069 -- make sure that the file exists as required by Ada semantics.
1071 if not Creat and then Fopstr (1) /= 'r' then
1072 if file_exists (Namestr'Address) = 0 then
1073 raise Name_Error with Errno_Message (Name);
1074 end if;
1075 end if;
1077 -- Now open the file. Note that we use the name as given in the
1078 -- original Open call for this purpose, since that seems the
1079 -- clearest implementation of the intent. It would presumably
1080 -- work to use the full name here, but if there is any difference,
1081 -- then we should use the name used in the call.
1083 -- Note: for a corresponding delete, we will use the full name,
1084 -- since by the time of the delete, the current working directory
1085 -- may have changed and we do not want to delete a different file.
1087 Stream :=
1088 fopen (Namestr'Address, Fopstr'Address, Encoding);
1090 if Stream = NULL_Stream then
1092 -- Raise Name_Error if trying to open a non-existent file.
1093 -- Otherwise raise Use_Error.
1095 -- Should we raise Device_Error for ENOSPC???
1097 declare
1098 function Is_File_Not_Found_Error
1099 (Errno_Value : Integer) return Integer;
1100 pragma Import
1101 (C, Is_File_Not_Found_Error,
1102 "__gnat_is_file_not_found_error");
1103 -- Non-zero when the given errno value indicates a non-
1104 -- existing file.
1106 Errno : constant Integer := OS_Lib.Errno;
1107 Message : constant String := Errno_Message (Name, Errno);
1109 begin
1110 if Is_File_Not_Found_Error (Errno) /= 0 then
1111 raise Name_Error with Message;
1112 else
1113 raise Use_Error with Message;
1114 end if;
1115 end;
1116 end if;
1117 end if;
1118 end if;
1120 -- Stream has been successfully located or opened, so now we are
1121 -- committed to completing the opening of the file. Allocate block on
1122 -- heap and fill in its fields.
1124 Record_AFCB;
1125 end Open;
1127 ------------------------
1128 -- Raise_Device_Error --
1129 ------------------------
1131 procedure Raise_Device_Error
1132 (File : AFCB_Ptr;
1133 Errno : Integer := OS_Lib.Errno)
1135 begin
1136 -- Clear error status so that the same error is not reported twice
1138 if File /= null then
1139 clearerr (File.Stream);
1140 end if;
1142 raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
1143 end Raise_Device_Error;
1145 --------------
1146 -- Read_Buf --
1147 --------------
1149 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1150 Nread : size_t;
1152 begin
1153 Nread := fread (Buf, 1, Siz, File.Stream);
1155 if Nread = Siz then
1156 return;
1158 elsif ferror (File.Stream) /= 0 then
1159 Raise_Device_Error (File);
1161 elsif Nread = 0 then
1162 raise End_Error;
1164 else -- 0 < Nread < Siz
1165 raise Data_Error with "not enough data read";
1166 end if;
1167 end Read_Buf;
1169 procedure Read_Buf
1170 (File : AFCB_Ptr;
1171 Buf : Address;
1172 Siz : Interfaces.C_Streams.size_t;
1173 Count : out Interfaces.C_Streams.size_t)
1175 begin
1176 Count := fread (Buf, 1, Siz, File.Stream);
1178 if Count = 0 and then ferror (File.Stream) /= 0 then
1179 Raise_Device_Error (File);
1180 end if;
1181 end Read_Buf;
1183 -----------
1184 -- Reset --
1185 -----------
1187 -- The reset which does not change the mode simply does a rewind
1189 procedure Reset (File_Ptr : access AFCB_Ptr) is
1190 File : AFCB_Ptr renames File_Ptr.all;
1191 begin
1192 Check_File_Open (File);
1193 Reset (File_Ptr, File.Mode);
1194 end Reset;
1196 -- The reset with a change in mode is done using freopen, and is not
1197 -- permitted except for regular files (since otherwise there is no name for
1198 -- the freopen, and in any case it seems meaningless).
1200 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
1201 File : AFCB_Ptr renames File_Ptr.all;
1202 Fopstr : aliased Fopen_String;
1204 begin
1205 Check_File_Open (File);
1207 -- Change of mode not allowed for shared file or file with no name or
1208 -- file that is not a regular file, or for a system file. Note that we
1209 -- allow the "change" of mode if it is not in fact doing a change.
1211 if Mode /= File.Mode then
1212 if File.Shared_Status = Yes then
1213 raise Use_Error with "cannot change mode of shared file";
1214 elsif File.Name'Length <= 1 then
1215 raise Use_Error with "cannot change mode of temp file";
1216 elsif File.Is_System_File then
1217 raise Use_Error with "cannot change mode of system file";
1218 elsif not File.Is_Regular_File then
1219 raise Use_Error with "cannot change mode of non-regular file";
1220 end if;
1221 end if;
1223 -- For In_File or Inout_File for a regular file, we can just do a rewind
1224 -- if the mode is unchanged, which is more efficient than doing a full
1225 -- reopen.
1227 if Mode = File.Mode
1228 and then Mode in Read_File_Mode
1229 then
1230 rewind (File.Stream);
1232 -- Here the change of mode is permitted, we do it by reopening the file
1233 -- in the new mode and replacing the stream with a new stream.
1235 else
1236 Fopen_Mode
1237 (Namestr => File.Name.all,
1238 Mode => Mode,
1239 Text => File.Text_Encoding in Text_Content_Encoding,
1240 Creat => False,
1241 Amethod => File.Access_Method,
1242 Fopstr => Fopstr);
1244 File.Stream := freopen
1245 (File.Name.all'Address, Fopstr'Address, File.Stream,
1246 File.Encoding);
1248 if File.Stream = NULL_Stream then
1249 Close (File_Ptr);
1250 raise Use_Error;
1251 else
1252 File.Mode := Mode;
1253 Append_Set (File);
1254 end if;
1255 end if;
1256 end Reset;
1258 ---------------
1259 -- Write_Buf --
1260 ---------------
1262 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1263 begin
1264 -- Note: for most purposes, the Siz and 1 parameters in the fwrite call
1265 -- could be reversed, but we have encountered systems where this is a
1266 -- better choice, since for some file formats, reversing the parameters
1267 -- results in records of one byte each.
1269 SSL.Abort_Defer.all;
1271 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1272 if Siz /= 0 then
1273 SSL.Abort_Undefer.all;
1274 Raise_Device_Error (File);
1275 end if;
1276 end if;
1278 SSL.Abort_Undefer.all;
1279 end Write_Buf;
1281 end System.File_IO;