gcc/
[official-gcc.git] / gcc / ada / s-fileio.adb
blob1d8882e3ad8b5a303fe1789507a5a24a4727e692
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-2014, 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 (Mode : File_Mode;
110 Text : Boolean;
111 Creat : Boolean;
112 Amethod : Character;
113 Fopstr : out Fopen_String);
114 -- Determines proper open mode for a file to be opened in the given Ada
115 -- mode. Text is true for a text file and false otherwise, and Creat is
116 -- true for a create call, and False for an open call. The value stored
117 -- in Fopstr is a nul-terminated string suitable for a call to fopen or
118 -- freopen. Amethod is the character designating the access method from
119 -- the Access_Method field of the FCB.
121 function Errno_Message
122 (Name : String;
123 Errno : Integer := OS_Lib.Errno) return String;
124 -- Return Errno_Message for Errno, with file name prepended
126 procedure Raise_Device_Error
127 (File : AFCB_Ptr;
128 Errno : Integer := OS_Lib.Errno);
129 pragma No_Return (Raise_Device_Error);
130 -- Clear error indication on File and raise Device_Error with an exception
131 -- message providing errno information.
133 ----------------
134 -- Append_Set --
135 ----------------
137 procedure Append_Set (File : AFCB_Ptr) is
138 begin
139 if File.Mode = Append_File then
140 if fseek (File.Stream, 0, SEEK_END) /= 0 then
141 Raise_Device_Error (File);
142 end if;
143 end if;
144 end Append_Set;
146 ----------------
147 -- Chain_File --
148 ----------------
150 procedure Chain_File (File : AFCB_Ptr) is
151 begin
152 -- Take a task lock, to protect the global data value Open_Files
154 SSL.Lock_Task.all;
156 -- Do the chaining operation locked
158 File.Next := Open_Files;
159 File.Prev := null;
160 Open_Files := File;
162 if File.Next /= null then
163 File.Next.Prev := File;
164 end if;
166 SSL.Unlock_Task.all;
168 exception
169 when others =>
170 SSL.Unlock_Task.all;
171 raise;
172 end Chain_File;
174 ---------------------
175 -- Check_File_Open --
176 ---------------------
178 procedure Check_File_Open (File : AFCB_Ptr) is
179 begin
180 if File = null then
181 raise Status_Error with "file not open";
182 end if;
183 end Check_File_Open;
185 -----------------------
186 -- Check_Read_Status --
187 -----------------------
189 procedure Check_Read_Status (File : AFCB_Ptr) is
190 begin
191 if File = null then
192 raise Status_Error with "file not open";
193 elsif File.Mode not in Read_File_Mode then
194 raise Mode_Error with "file not readable";
195 end if;
196 end Check_Read_Status;
198 ------------------------
199 -- Check_Write_Status --
200 ------------------------
202 procedure Check_Write_Status (File : AFCB_Ptr) is
203 begin
204 if File = null then
205 raise Status_Error with "file not open";
206 elsif File.Mode = In_File then
207 raise Mode_Error with "file not writable";
208 end if;
209 end Check_Write_Status;
211 -----------
212 -- Close --
213 -----------
215 procedure Close (File_Ptr : access AFCB_Ptr) is
216 Close_Status : int := 0;
217 Dup_Strm : Boolean := False;
218 Errno : Integer := 0;
220 File : AFCB_Ptr renames File_Ptr.all;
222 begin
223 -- Take a task lock, to protect the global data value Open_Files
225 SSL.Lock_Task.all;
227 Check_File_Open (File);
228 AFCB_Close (File);
230 -- Sever the association between the given file and its associated
231 -- external file. The given file is left closed. Do not perform system
232 -- closes on the standard input, output and error files and also do not
233 -- attempt to close a stream that does not exist (signalled by a null
234 -- stream value -- happens in some error situations).
236 if not File.Is_System_File and then File.Stream /= NULL_Stream then
238 -- Do not do an fclose if this is a shared file and there is at least
239 -- one other instance of the stream that is open.
241 if File.Shared_Status = Yes then
242 declare
243 P : AFCB_Ptr;
245 begin
246 P := Open_Files;
247 while P /= null loop
248 if P /= File and then File.Stream = P.Stream then
249 Dup_Strm := True;
250 exit;
251 end if;
253 P := P.Next;
254 end loop;
255 end;
256 end if;
258 -- Do the fclose unless this was a duplicate in the shared case
260 if not Dup_Strm then
261 Close_Status := fclose (File.Stream);
263 if Close_Status /= 0 then
264 Errno := OS_Lib.Errno;
265 end if;
266 end if;
267 end if;
269 -- Dechain file from list of open files and then free the storage
271 if File.Prev = null then
272 Open_Files := File.Next;
273 else
274 File.Prev.Next := File.Next;
275 end if;
277 if File.Next /= null then
278 File.Next.Prev := File.Prev;
279 end if;
281 -- Deallocate some parts of the file structure that were kept in heap
282 -- storage with the exception of system files (standard input, output
283 -- and error) since they had some information allocated in the stack.
285 if not File.Is_System_File then
286 Free_String (File.Name);
287 Free_String (File.Form);
288 AFCB_Free (File);
289 end if;
291 File := null;
293 if Close_Status /= 0 then
294 Raise_Device_Error (null, Errno);
295 end if;
297 SSL.Unlock_Task.all;
299 exception
300 when others =>
301 SSL.Unlock_Task.all;
302 raise;
303 end Close;
305 ------------
306 -- Delete --
307 ------------
309 procedure Delete (File_Ptr : access AFCB_Ptr) is
310 File : AFCB_Ptr renames File_Ptr.all;
312 begin
313 Check_File_Open (File);
315 if not File.Is_Regular_File then
316 raise Use_Error with "cannot delete non-regular file";
317 end if;
319 declare
320 Filename : aliased constant String := File.Name.all;
322 begin
323 Close (File_Ptr);
325 -- Now unlink the external file. Note that we use the full name in
326 -- this unlink, because the working directory may have changed since
327 -- we did the open, and we want to unlink the right file.
329 if unlink (Filename'Address) = -1 then
330 raise Use_Error with OS_Lib.Errno_Message;
331 end if;
332 end;
333 end Delete;
335 -----------------
336 -- End_Of_File --
337 -----------------
339 function End_Of_File (File : AFCB_Ptr) return Boolean is
340 begin
341 Check_File_Open (File);
343 if feof (File.Stream) /= 0 then
344 return True;
346 else
347 Check_Read_Status (File);
349 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
350 clearerr (File.Stream);
351 return True;
352 else
353 return False;
354 end if;
355 end if;
356 end End_Of_File;
358 -------------------
359 -- Errno_Message --
360 -------------------
362 function Errno_Message
363 (Name : String;
364 Errno : Integer := OS_Lib.Errno) return String
366 begin
367 return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
368 end Errno_Message;
370 --------------
371 -- Finalize --
372 --------------
374 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
375 pragma Warnings (Off, V);
377 Fptr1 : aliased AFCB_Ptr;
378 Fptr2 : AFCB_Ptr;
380 Discard : int;
382 begin
383 -- Take a lock to protect global Open_Files data structure
385 SSL.Lock_Task.all;
387 -- First close all open files (the slightly complex form of this loop is
388 -- required because Close as a side effect nulls out its argument).
390 Fptr1 := Open_Files;
391 while Fptr1 /= null loop
392 Fptr2 := Fptr1.Next;
393 Close (Fptr1'Access);
394 Fptr1 := Fptr2;
395 end loop;
397 -- Now unlink all temporary files. We do not bother to free the blocks
398 -- because we are just about to terminate the program. We also ignore
399 -- any errors while attempting these unlink operations.
401 while Temp_Files /= null loop
402 Discard := unlink (Temp_Files.Name'Address);
403 Temp_Files := Temp_Files.Next;
404 end loop;
406 SSL.Unlock_Task.all;
408 exception
409 when others =>
410 SSL.Unlock_Task.all;
411 raise;
412 end Finalize;
414 -----------
415 -- Flush --
416 -----------
418 procedure Flush (File : AFCB_Ptr) is
419 begin
420 Check_Write_Status (File);
422 if fflush (File.Stream) /= 0 then
423 Raise_Device_Error (File);
424 end if;
425 end Flush;
427 ----------------
428 -- Fopen_Mode --
429 ----------------
431 -- The fopen mode to be used is shown by the following table:
433 -- OPEN CREATE
434 -- Append_File "r+" "w+"
435 -- In_File "r" "w+"
436 -- Out_File (Direct_IO) "r+" "w"
437 -- Out_File (all others) "w" "w"
438 -- Inout_File "r+" "w+"
440 -- Note: we do not use "a" or "a+" for Append_File, since this would not
441 -- work in the case of stream files, where even if in append file mode,
442 -- you can reset to earlier points in the file. The caller must use the
443 -- Append_Set routine to deal with the necessary positioning.
445 -- Note: in several cases, the fopen mode used allows reading and writing,
446 -- but the setting of the Ada mode is more restrictive. For instance,
447 -- Create in In_File mode uses "w+" which allows writing, but the Ada mode
448 -- In_File will cause any write operations to be rejected with Mode_Error
449 -- in any case.
451 -- Note: for the Out_File/Open cases for other than the Direct_IO case, an
452 -- initial call will be made by the caller to first open the file in "r"
453 -- mode to be sure that it exists. The real open, in "w" mode, will then
454 -- destroy this file. This is peculiar, but that's what Ada semantics
455 -- require and the ACATS tests insist on.
457 -- If text file translation is required, then either "b" or "t" is appended
458 -- to the mode, depending on the setting of Text.
460 procedure Fopen_Mode
461 (Mode : File_Mode;
462 Text : Boolean;
463 Creat : Boolean;
464 Amethod : Character;
465 Fopstr : out Fopen_String)
467 Fptr : Positive;
469 begin
470 case Mode is
471 when In_File =>
472 if Creat then
473 Fopstr (1) := 'w';
474 Fopstr (2) := '+';
475 Fptr := 3;
476 else
477 Fopstr (1) := 'r';
478 Fptr := 2;
479 end if;
481 when Out_File =>
482 if Amethod = 'D' and then not Creat then
483 Fopstr (1) := 'r';
484 Fopstr (2) := '+';
485 Fptr := 3;
486 else
487 Fopstr (1) := 'w';
488 Fptr := 2;
489 end if;
491 when Inout_File | Append_File =>
492 Fopstr (1) := (if Creat then 'w' else 'r');
493 Fopstr (2) := '+';
494 Fptr := 3;
495 end case;
497 -- If text_translation_required is true then we need to append either a
498 -- "t" or "b" to the string to get the right mode.
500 if text_translation_required then
501 Fopstr (Fptr) := (if Text then 't' else 'b');
502 Fptr := Fptr + 1;
503 end if;
505 Fopstr (Fptr) := ASCII.NUL;
506 end Fopen_Mode;
508 ----------
509 -- Form --
510 ----------
512 function Form (File : AFCB_Ptr) return String is
513 begin
514 if File = null then
515 raise Status_Error with "Form: file not open";
516 else
517 return File.Form.all (1 .. File.Form'Length - 1);
518 end if;
519 end Form;
521 ------------------
522 -- Form_Boolean --
523 ------------------
525 function Form_Boolean
526 (Form : String;
527 Keyword : String;
528 Default : Boolean) return Boolean
530 V1, V2 : Natural;
531 pragma Unreferenced (V2);
533 begin
534 Form_Parameter (Form, Keyword, V1, V2);
536 if V1 = 0 then
537 return Default;
538 elsif Form (V1) = 'y' then
539 return True;
540 elsif Form (V1) = 'n' then
541 return False;
542 else
543 raise Use_Error with "invalid Form";
544 end if;
545 end Form_Boolean;
547 ------------------
548 -- Form_Integer --
549 ------------------
551 function Form_Integer
552 (Form : String;
553 Keyword : String;
554 Default : Integer) return Integer
556 V1, V2 : Natural;
557 V : Integer;
559 begin
560 Form_Parameter (Form, Keyword, V1, V2);
562 if V1 = 0 then
563 return Default;
565 else
566 V := 0;
568 for J in V1 .. V2 loop
569 if Form (J) not in '0' .. '9' then
570 raise Use_Error with "invalid Form";
571 else
572 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
573 end if;
575 if V > 999_999 then
576 raise Use_Error with "invalid Form";
577 end if;
578 end loop;
580 return V;
581 end if;
582 end Form_Integer;
584 --------------------
585 -- Form_Parameter --
586 --------------------
588 procedure Form_Parameter
589 (Form : String;
590 Keyword : String;
591 Start : out Natural;
592 Stop : out Natural)
594 Klen : constant Integer := Keyword'Length;
596 begin
597 for J in Form'First + Klen .. Form'Last - 1 loop
598 if Form (J) = '='
599 and then Form (J - Klen .. J - 1) = Keyword
600 then
601 Start := J + 1;
602 Stop := Start - 1;
603 while Form (Stop + 1) /= ASCII.NUL
604 and then Form (Stop + 1) /= ','
605 loop
606 Stop := Stop + 1;
607 end loop;
609 return;
610 end if;
611 end loop;
613 Start := 0;
614 Stop := 0;
615 end Form_Parameter;
617 -------------
618 -- Is_Open --
619 -------------
621 function Is_Open (File : AFCB_Ptr) return Boolean is
622 begin
623 -- We return True if the file is open, and the underlying file stream is
624 -- usable. In particular on Windows an application linked with -mwindows
625 -- option set does not have a console attached. In this case standard
626 -- files (Current_Output, Current_Error, Current_Input) are not created.
627 -- We want Is_Open (Current_Output) to return False in this case.
629 return File /= null and then fileno (File.Stream) /= -1;
630 end Is_Open;
632 -------------------
633 -- Make_Buffered --
634 -------------------
636 procedure Make_Buffered
637 (File : AFCB_Ptr;
638 Buf_Siz : Interfaces.C_Streams.size_t)
640 status : Integer;
641 pragma Unreferenced (status);
643 begin
644 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
645 end Make_Buffered;
647 ------------------------
648 -- Make_Line_Buffered --
649 ------------------------
651 procedure Make_Line_Buffered
652 (File : AFCB_Ptr;
653 Line_Siz : Interfaces.C_Streams.size_t)
655 status : Integer;
656 pragma Unreferenced (status);
658 begin
659 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
660 -- No error checking???
661 end Make_Line_Buffered;
663 ---------------------
664 -- Make_Unbuffered --
665 ---------------------
667 procedure Make_Unbuffered (File : AFCB_Ptr) is
668 status : Integer;
669 pragma Unreferenced (status);
671 begin
672 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
673 -- No error checking???
674 end Make_Unbuffered;
676 ----------
677 -- Mode --
678 ----------
680 function Mode (File : AFCB_Ptr) return File_Mode is
681 begin
682 if File = null then
683 raise Status_Error with "Mode: file not open";
684 else
685 return File.Mode;
686 end if;
687 end Mode;
689 ----------
690 -- Name --
691 ----------
693 function Name (File : AFCB_Ptr) return String is
694 begin
695 if File = null then
696 raise Status_Error with "Name: file not open";
697 else
698 return File.Name.all (1 .. File.Name'Length - 1);
699 end if;
700 end Name;
702 ----------
703 -- Open --
704 ----------
706 procedure Open
707 (File_Ptr : in out AFCB_Ptr;
708 Dummy_FCB : AFCB'Class;
709 Mode : File_Mode;
710 Name : String;
711 Form : String;
712 Amethod : Character;
713 Creat : Boolean;
714 Text : Boolean;
715 C_Stream : FILEs := NULL_Stream)
717 pragma Warnings (Off, Dummy_FCB);
718 -- Yes we know this is never assigned a value. That's intended, since
719 -- all we ever use of this value is the tag for dispatching purposes.
721 procedure Tmp_Name (Buffer : Address);
722 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
723 -- Set buffer (a String address) with a temporary filename
725 function Get_Case_Sensitive return Integer;
726 pragma Import (C, Get_Case_Sensitive,
727 "__gnat_get_file_names_case_sensitive");
729 procedure Record_AFCB;
730 -- Create and record new AFCB into the runtime, note that the
731 -- implementation uses the variables below which corresponds to the
732 -- status of the opened file.
734 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0;
735 -- Set to indicate whether the operating system convention is for file
736 -- names to be case sensitive (e.g., in Unix, set True), or not case
737 -- sensitive (e.g., in Windows, set False). Declared locally to avoid
738 -- breaking the Preelaborate rule that disallows function calls at the
739 -- library level.
741 Stream : FILEs := C_Stream;
742 -- Stream which we open in response to this request
744 Shared : Shared_Status_Type;
745 -- Setting of Shared_Status field for file
747 Fopstr : aliased Fopen_String;
748 -- Mode string used in fopen call
750 Formstr : aliased String (1 .. Form'Length + 1);
751 -- Form string with ASCII.NUL appended, folded to lower case
753 Text_Encoding : Content_Encoding;
755 Tempfile : constant Boolean := (Name'Length = 0);
756 -- Indicates temporary file case
758 Namelen : constant Integer := max_path_len;
759 -- Length required for file name, not including final ASCII.NUL.
760 -- Note that we used to reference L_tmpnam here, which is not reliable
761 -- since __gnat_tmp_name does not always use tmpnam.
763 Namestr : aliased String (1 .. Namelen + 1);
764 -- Name as given or temporary file name with ASCII.NUL appended
766 Fullname : aliased String (1 .. max_path_len + 1);
767 -- Full name (as required for Name function, and as stored in the
768 -- control block in the Name field) with ASCII.NUL appended.
770 Full_Name_Len : Integer;
771 -- Length of name actually stored in Fullname
773 Encoding : CRTL.Filename_Encoding;
774 -- Filename encoding specified into the form parameter
776 -----------------
777 -- Record_AFCB --
778 -----------------
780 procedure Record_AFCB is
781 begin
782 File_Ptr := AFCB_Allocate (Dummy_FCB);
784 -- Note that we cannot use an aggregate here as File_Ptr is a
785 -- class-wide access to a limited type (Root_Stream_Type).
787 File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0;
788 File_Ptr.Is_System_File := False;
789 File_Ptr.Text_Encoding := Text_Encoding;
790 File_Ptr.Shared_Status := Shared;
791 File_Ptr.Access_Method := Amethod;
792 File_Ptr.Stream := Stream;
793 File_Ptr.Form := new String'(Formstr);
794 File_Ptr.Name := new String'(Fullname
795 (1 .. Full_Name_Len));
796 File_Ptr.Mode := Mode;
797 File_Ptr.Is_Temporary_File := Tempfile;
798 File_Ptr.Encoding := Encoding;
800 Chain_File (File_Ptr);
801 Append_Set (File_Ptr);
802 end Record_AFCB;
804 -- Start of processing for Open
806 begin
807 if File_Ptr /= null then
808 raise Status_Error with "file already open";
809 end if;
811 -- Acquire form string, setting required NUL terminator
813 Formstr (1 .. Form'Length) := Form;
814 Formstr (Formstr'Last) := ASCII.NUL;
816 -- Convert form string to lower case
818 for J in Formstr'Range loop
819 if Formstr (J) in 'A' .. 'Z' then
820 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
821 end if;
822 end loop;
824 -- Acquire setting of shared parameter
826 declare
827 V1, V2 : Natural;
829 begin
830 Form_Parameter (Formstr, "shared", V1, V2);
832 if V1 = 0 then
833 Shared := None;
834 elsif Formstr (V1 .. V2) = "yes" then
835 Shared := Yes;
836 elsif Formstr (V1 .. V2) = "no" then
837 Shared := No;
838 else
839 raise Use_Error with "invalid Form";
840 end if;
841 end;
843 -- Acquire setting of encoding parameter
845 declare
846 V1, V2 : Natural;
848 begin
849 Form_Parameter (Formstr, "encoding", V1, V2);
851 if V1 = 0 then
852 Encoding := CRTL.Unspecified;
853 elsif Formstr (V1 .. V2) = "utf8" then
854 Encoding := CRTL.UTF8;
855 elsif Formstr (V1 .. V2) = "8bits" then
856 Encoding := CRTL.ASCII_8bits;
857 else
858 raise Use_Error with "invalid Form";
859 end if;
860 end;
862 -- Acquire setting of text_translation parameter. Only needed if this is
863 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but
864 -- if the Form says Text_Translation=No, we use binary mode, so new-line
865 -- will be just LF, even on Windows.
867 if Text then
868 Text_Encoding := Default_Text;
869 else
870 Text_Encoding := None;
871 end if;
873 if Text_Encoding in Text_Content_Encoding then
874 declare
875 V1, V2 : Natural;
877 begin
878 Form_Parameter (Formstr, "text_translation", V1, V2);
880 if V1 = 0 then
881 null;
882 elsif Formstr (V1 .. V2) = "no" then
883 Text_Encoding := None;
884 elsif Formstr (V1 .. V2) = "text"
885 or else Formstr (V1 .. V2) = "yes"
886 then
887 Text_Encoding := Interfaces.C_Streams.Text;
888 elsif Formstr (V1 .. V2) = "wtext" then
889 Text_Encoding := Wtext;
890 elsif Formstr (V1 .. V2) = "u8text" then
891 Text_Encoding := U8text;
892 elsif Formstr (V1 .. V2) = "u16text" then
893 Text_Encoding := U16text;
894 else
895 raise Use_Error with "invalid Form";
896 end if;
897 end;
898 end if;
900 -- If we were given a stream (call from xxx.C_Streams.Open), then set
901 -- the full name to the given one, and skip to end of processing.
903 if Stream /= NULL_Stream then
904 Full_Name_Len := Name'Length + 1;
905 Fullname (1 .. Full_Name_Len - 1) := Name;
906 Fullname (Full_Name_Len) := ASCII.NUL;
908 -- Normal case of Open or Create
910 else
911 -- If temporary file case, get temporary file name and add to the
912 -- list of temporary files to be deleted on exit.
914 if Tempfile then
915 if not Creat then
916 raise Name_Error with "opening temp file without creating it";
917 end if;
919 Tmp_Name (Namestr'Address);
921 if Namestr (1) = ASCII.NUL then
922 raise Use_Error with "invalid temp file name";
923 end if;
925 -- Chain to temp file list, ensuring thread safety with a lock
927 begin
928 SSL.Lock_Task.all;
929 Temp_Files :=
930 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
931 SSL.Unlock_Task.all;
933 exception
934 when others =>
935 SSL.Unlock_Task.all;
936 raise;
937 end;
939 -- Normal case of non-null name given
941 else
942 if Name'Length > Namelen then
943 raise Name_Error with "file name too long";
944 end if;
946 Namestr (1 .. Name'Length) := Name;
947 Namestr (Name'Length + 1) := ASCII.NUL;
948 end if;
950 -- Get full name in accordance with the advice of RM A.8.2(22)
952 full_name (Namestr'Address, Fullname'Address);
954 if Fullname (1) = ASCII.NUL then
955 raise Use_Error with Errno_Message (Name);
956 end if;
958 Full_Name_Len := 1;
959 while Full_Name_Len < Fullname'Last
960 and then Fullname (Full_Name_Len) /= ASCII.NUL
961 loop
962 Full_Name_Len := Full_Name_Len + 1;
963 end loop;
965 -- Fullname is generated by calling system's full_name. The problem
966 -- is, full_name does nothing about the casing, so a file name
967 -- comparison may generally speaking not be valid on non-case-
968 -- sensitive systems, and in particular we get unexpected failures
969 -- on Windows/Vista because of this. So we use s-casuti to force
970 -- the name to lower case.
972 if not File_Names_Case_Sensitive then
973 To_Lower (Fullname (1 .. Full_Name_Len));
974 end if;
976 -- If Shared=None or Shared=Yes, then check for the existence of
977 -- another file with exactly the same full name.
979 if Shared /= No then
980 declare
981 P : AFCB_Ptr;
983 begin
984 -- Take a task lock to protect Open_Files
986 SSL.Lock_Task.all;
988 -- Search list of open files
990 P := Open_Files;
991 while P /= null loop
992 if Fullname (1 .. Full_Name_Len) = P.Name.all then
994 -- If we get a match, and either file has Shared=None,
995 -- then raise Use_Error, since we don't allow two files
996 -- of the same name to be opened unless they specify the
997 -- required sharing mode.
999 if Shared = None
1000 or else P.Shared_Status = None
1001 then
1002 raise Use_Error with "reopening shared file";
1004 -- If both files have Shared=Yes, then we acquire the
1005 -- stream from the located file to use as our stream.
1007 elsif Shared = Yes
1008 and then P.Shared_Status = Yes
1009 then
1010 Stream := P.Stream;
1012 Record_AFCB;
1014 exit;
1016 -- Otherwise one of the files has Shared=Yes and one has
1017 -- Shared=No. If the current file has Shared=No then all
1018 -- is well but we don't want to share any other file's
1019 -- stream. If the current file has Shared=Yes, we would
1020 -- like to share a stream, but not from a file that has
1021 -- Shared=No, so either way, we just continue the search.
1023 else
1024 null;
1025 end if;
1026 end if;
1028 P := P.Next;
1029 end loop;
1031 SSL.Unlock_Task.all;
1033 exception
1034 when others =>
1035 SSL.Unlock_Task.all;
1036 raise;
1037 end;
1038 end if;
1040 -- Open specified file if we did not find an existing stream,
1041 -- otherwise we just return as there is nothing more to be done.
1043 if Stream /= NULL_Stream then
1044 return;
1046 else
1047 Fopen_Mode
1048 (Mode, Text_Encoding in Text_Content_Encoding,
1049 Creat, Amethod, Fopstr);
1051 -- A special case, if we are opening (OPEN case) a file and the
1052 -- mode returned by Fopen_Mode is not "r" or "r+", then we first
1053 -- make sure that the file exists as required by Ada semantics.
1055 if not Creat and then Fopstr (1) /= 'r' then
1056 if file_exists (Namestr'Address) = 0 then
1057 raise Name_Error with Errno_Message (Name);
1058 end if;
1059 end if;
1061 -- Now open the file. Note that we use the name as given in the
1062 -- original Open call for this purpose, since that seems the
1063 -- clearest implementation of the intent. It would presumably
1064 -- work to use the full name here, but if there is any difference,
1065 -- then we should use the name used in the call.
1067 -- Note: for a corresponding delete, we will use the full name,
1068 -- since by the time of the delete, the current working directory
1069 -- may have changed and we do not want to delete a different file.
1071 Stream :=
1072 fopen (Namestr'Address, Fopstr'Address, Encoding);
1074 if Stream = NULL_Stream then
1076 -- Raise Name_Error if trying to open a non-existent file.
1077 -- Otherwise raise Use_Error.
1079 -- Should we raise Device_Error for ENOSPC???
1081 declare
1082 function Is_File_Not_Found_Error
1083 (Errno_Value : Integer) return Integer;
1084 pragma Import
1085 (C, Is_File_Not_Found_Error,
1086 "__gnat_is_file_not_found_error");
1087 -- Non-zero when the given errno value indicates a non-
1088 -- existing file.
1090 Errno : constant Integer := OS_Lib.Errno;
1091 Message : constant String := Errno_Message (Name, Errno);
1093 begin
1094 if Is_File_Not_Found_Error (Errno) /= 0 then
1095 raise Name_Error with Message;
1096 else
1097 raise Use_Error with Message;
1098 end if;
1099 end;
1100 end if;
1101 end if;
1102 end if;
1104 -- Stream has been successfully located or opened, so now we are
1105 -- committed to completing the opening of the file. Allocate block on
1106 -- heap and fill in its fields.
1108 Record_AFCB;
1109 end Open;
1111 ------------------------
1112 -- Raise_Device_Error --
1113 ------------------------
1115 procedure Raise_Device_Error
1116 (File : AFCB_Ptr;
1117 Errno : Integer := OS_Lib.Errno)
1119 begin
1120 -- Clear error status so that the same error is not reported twice
1122 if File /= null then
1123 clearerr (File.Stream);
1124 end if;
1126 raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
1127 end Raise_Device_Error;
1129 --------------
1130 -- Read_Buf --
1131 --------------
1133 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1134 Nread : size_t;
1136 begin
1137 Nread := fread (Buf, 1, Siz, File.Stream);
1139 if Nread = Siz then
1140 return;
1142 elsif ferror (File.Stream) /= 0 then
1143 Raise_Device_Error (File);
1145 elsif Nread = 0 then
1146 raise End_Error;
1148 else -- 0 < Nread < Siz
1149 raise Data_Error with "not enough data read";
1150 end if;
1151 end Read_Buf;
1153 procedure Read_Buf
1154 (File : AFCB_Ptr;
1155 Buf : Address;
1156 Siz : Interfaces.C_Streams.size_t;
1157 Count : out Interfaces.C_Streams.size_t)
1159 begin
1160 Count := fread (Buf, 1, Siz, File.Stream);
1162 if Count = 0 and then ferror (File.Stream) /= 0 then
1163 Raise_Device_Error (File);
1164 end if;
1165 end Read_Buf;
1167 -----------
1168 -- Reset --
1169 -----------
1171 -- The reset which does not change the mode simply does a rewind
1173 procedure Reset (File_Ptr : access AFCB_Ptr) is
1174 File : AFCB_Ptr renames File_Ptr.all;
1175 begin
1176 Check_File_Open (File);
1177 Reset (File_Ptr, File.Mode);
1178 end Reset;
1180 -- The reset with a change in mode is done using freopen, and is not
1181 -- permitted except for regular files (since otherwise there is no name for
1182 -- the freopen, and in any case it seems meaningless).
1184 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is
1185 File : AFCB_Ptr renames File_Ptr.all;
1186 Fopstr : aliased Fopen_String;
1188 begin
1189 Check_File_Open (File);
1191 -- Change of mode not allowed for shared file or file with no name or
1192 -- file that is not a regular file, or for a system file. Note that we
1193 -- allow the "change" of mode if it is not in fact doing a change.
1195 if Mode /= File.Mode then
1196 if File.Shared_Status = Yes then
1197 raise Use_Error with "cannot change mode of shared file";
1198 elsif File.Name'Length <= 1 then
1199 raise Use_Error with "cannot change mode of temp file";
1200 elsif File.Is_System_File then
1201 raise Use_Error with "cannot change mode of system file";
1202 elsif not File.Is_Regular_File then
1203 raise Use_Error with "cannot change mode of non-regular file";
1204 end if;
1205 end if;
1207 -- For In_File or Inout_File for a regular file, we can just do a rewind
1208 -- if the mode is unchanged, which is more efficient than doing a full
1209 -- reopen.
1211 if Mode = File.Mode
1212 and then Mode in Read_File_Mode
1213 then
1214 rewind (File.Stream);
1216 -- Here the change of mode is permitted, we do it by reopening the file
1217 -- in the new mode and replacing the stream with a new stream.
1219 else
1220 Fopen_Mode
1221 (Mode, File.Text_Encoding in Text_Content_Encoding,
1222 False, File.Access_Method, Fopstr);
1224 File.Stream := freopen
1225 (File.Name.all'Address, Fopstr'Address, File.Stream,
1226 File.Encoding);
1228 if File.Stream = NULL_Stream then
1229 Close (File_Ptr);
1230 raise Use_Error;
1231 else
1232 File.Mode := Mode;
1233 Append_Set (File);
1234 end if;
1235 end if;
1236 end Reset;
1238 ---------------
1239 -- Write_Buf --
1240 ---------------
1242 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1243 begin
1244 -- Note: for most purposes, the Siz and 1 parameters in the fwrite call
1245 -- could be reversed, but we have encountered systems where this is a
1246 -- better choice, since for some file formats, reversing the parameters
1247 -- results in records of one byte each.
1249 SSL.Abort_Defer.all;
1251 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1252 if Siz /= 0 then
1253 SSL.Abort_Undefer.all;
1254 Raise_Device_Error (File);
1255 end if;
1256 end if;
1258 SSL.Abort_Undefer.all;
1259 end Write_Buf;
1261 end System.File_IO;