gcc:
[official-gcc.git] / gcc / ada / s-fileio.adb
blob4317cb3114286831457d52c2604e2832f6eefc08
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-2006, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
21 -- --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
28 -- --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
31 -- --
32 ------------------------------------------------------------------------------
34 with Ada.Finalization; use Ada.Finalization;
35 with Ada.IO_Exceptions; use Ada.IO_Exceptions;
36 with Interfaces.C_Streams; use Interfaces.C_Streams;
37 with System.CRTL;
38 with System.Soft_Links;
39 with Unchecked_Deallocation;
41 package body System.File_IO is
43 use System.File_Control_Block;
45 package SSL renames System.Soft_Links;
47 use type System.CRTL.size_t;
49 ----------------------
50 -- Global Variables --
51 ----------------------
53 Open_Files : AFCB_Ptr;
54 -- This points to a list of AFCB's for all open files. This is a doubly
55 -- linked list, with the Prev pointer of the first entry, and the Next
56 -- pointer of the last entry containing null. Note that this global
57 -- variable must be properly protected to provide thread safety.
59 type Temp_File_Record;
60 type Temp_File_Record_Ptr is access all Temp_File_Record;
62 type Temp_File_Record is record
63 Name : String (1 .. max_path_len + 1);
64 Next : Temp_File_Record_Ptr;
65 end record;
66 -- One of these is allocated for each temporary file created
68 Temp_Files : Temp_File_Record_Ptr;
69 -- Points to list of names of temporary files. Note that this global
70 -- variable must be properly protected to provide thread safety.
72 type File_IO_Clean_Up_Type is new Controlled with null record;
73 -- The closing of all open files and deletion of temporary files is an
74 -- action which takes place at the end of execution of the main program.
75 -- This action can be implemented using a library level object which
76 -- gets finalized at the end of the main program execution. The above is
77 -- a controlled type introduced for this purpose.
79 procedure Finalize (V : in out File_IO_Clean_Up_Type);
80 -- This is the finalize operation that is used to do the cleanup
82 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type;
83 pragma Warnings (Off, File_IO_Clean_Up_Object);
84 -- This is the single object of the type that triggers the finalization
85 -- call. Since it is at the library level, this happens just before the
86 -- environment task is finalized.
88 text_translation_required : Boolean;
89 pragma Import
90 (C, text_translation_required, "__gnat_text_translation_required");
91 -- If true, add appropriate suffix to control string for Open
93 -----------------------
94 -- Local Subprograms --
95 -----------------------
97 procedure Free_String is new Unchecked_Deallocation (String, Pstring);
99 subtype Fopen_String is String (1 .. 4);
100 -- Holds open string (longest is "w+b" & nul)
102 procedure Fopen_Mode
103 (Mode : File_Mode;
104 Text : Boolean;
105 Creat : Boolean;
106 Amethod : Character;
107 Fopstr : out Fopen_String);
108 -- Determines proper open mode for a file to be opened in the given
109 -- Ada mode. Text is true for a text file and false otherwise, and
110 -- Creat is true for a create call, and False for an open call. The
111 -- value stored in Fopstr is a nul-terminated string suitable for a
112 -- call to fopen or freopen. Amethod is the character designating
113 -- the access method from the Access_Method field of the FCB.
115 ----------------
116 -- Append_Set --
117 ----------------
119 procedure Append_Set (File : AFCB_Ptr) is
120 begin
121 if File.Mode = Append_File then
122 if fseek (File.Stream, 0, SEEK_END) /= 0 then
123 raise Device_Error;
124 end if;
125 end if;
126 end Append_Set;
128 ----------------
129 -- Chain_File --
130 ----------------
132 procedure Chain_File (File : AFCB_Ptr) is
133 begin
134 -- Take a task lock, to protect the global data value Open_Files
136 SSL.Lock_Task.all;
138 -- Do the chaining operation locked
140 File.Next := Open_Files;
141 File.Prev := null;
142 Open_Files := File;
144 if File.Next /= null then
145 File.Next.Prev := File;
146 end if;
148 SSL.Unlock_Task.all;
150 exception
151 when others =>
152 SSL.Unlock_Task.all;
153 raise;
154 end Chain_File;
156 ---------------------
157 -- Check_File_Open --
158 ---------------------
160 procedure Check_File_Open (File : AFCB_Ptr) is
161 begin
162 if File = null then
163 raise Status_Error;
164 end if;
165 end Check_File_Open;
167 -----------------------
168 -- Check_Read_Status --
169 -----------------------
171 procedure Check_Read_Status (File : AFCB_Ptr) is
172 begin
173 if File = null then
174 raise Status_Error;
175 elsif File.Mode > Inout_File then
176 raise Mode_Error;
177 end if;
178 end Check_Read_Status;
180 ------------------------
181 -- Check_Write_Status --
182 ------------------------
184 procedure Check_Write_Status (File : AFCB_Ptr) is
185 begin
186 if File = null then
187 raise Status_Error;
188 elsif File.Mode = In_File then
189 raise Mode_Error;
190 end if;
191 end Check_Write_Status;
193 -----------
194 -- Close --
195 -----------
197 procedure Close (File : in out AFCB_Ptr) is
198 Close_Status : int := 0;
199 Dup_Strm : Boolean := False;
201 begin
202 Check_File_Open (File);
203 AFCB_Close (File);
205 -- Take a task lock, to protect the global data value Open_Files
207 SSL.Lock_Task.all;
209 -- Sever the association between the given file and its associated
210 -- external file. The given file is left closed. Do not perform system
211 -- closes on the standard input, output and error files and also do
212 -- not attempt to close a stream that does not exist (signalled by a
213 -- null stream value -- happens in some error situations).
215 if not File.Is_System_File
216 and then File.Stream /= NULL_Stream
217 then
218 -- Do not do an fclose if this is a shared file and there is
219 -- at least one other instance of the stream that is open.
221 if File.Shared_Status = Yes then
222 declare
223 P : AFCB_Ptr;
225 begin
226 P := Open_Files;
227 while P /= null loop
228 if P /= File
229 and then File.Stream = P.Stream
230 then
231 Dup_Strm := True;
232 exit;
233 end if;
235 P := P.Next;
236 end loop;
237 end;
238 end if;
240 -- Do the fclose unless this was a duplicate in the shared case
242 if not Dup_Strm then
243 Close_Status := fclose (File.Stream);
244 end if;
245 end if;
247 -- Dechain file from list of open files and then free the storage
249 if File.Prev = null then
250 Open_Files := File.Next;
251 else
252 File.Prev.Next := File.Next;
253 end if;
255 if File.Next /= null then
256 File.Next.Prev := File.Prev;
257 end if;
259 -- Deallocate some parts of the file structure that were kept in heap
260 -- storage with the exception of system files (standard input, output
261 -- and error) since they had some information allocated in the stack.
263 if not File.Is_System_File then
264 Free_String (File.Name);
265 Free_String (File.Form);
266 AFCB_Free (File);
267 end if;
269 File := null;
271 if Close_Status /= 0 then
272 raise Device_Error;
273 end if;
275 SSL.Unlock_Task.all;
277 exception
278 when others =>
279 SSL.Unlock_Task.all;
280 raise;
281 end Close;
283 ------------
284 -- Delete --
285 ------------
287 procedure Delete (File : in out AFCB_Ptr) is
288 begin
289 Check_File_Open (File);
291 if not File.Is_Regular_File then
292 raise Use_Error;
293 end if;
295 declare
296 Filename : aliased constant String := File.Name.all;
298 begin
299 Close (File);
301 -- Now unlink the external file. Note that we use the full name
302 -- in this unlink, because the working directory may have changed
303 -- since we did the open, and we want to unlink the right file!
305 if unlink (Filename'Address) = -1 then
306 raise Use_Error;
307 end if;
308 end;
309 end Delete;
311 -----------------
312 -- End_Of_File --
313 -----------------
315 function End_Of_File (File : AFCB_Ptr) return Boolean is
316 begin
317 Check_File_Open (File);
319 if feof (File.Stream) /= 0 then
320 return True;
322 else
323 Check_Read_Status (File);
325 if ungetc (fgetc (File.Stream), File.Stream) = EOF then
326 clearerr (File.Stream);
327 return True;
328 else
329 return False;
330 end if;
331 end if;
332 end End_Of_File;
334 --------------
335 -- Finalize --
336 --------------
338 -- Note: we do not need to worry about locking against multiple task
339 -- access in this routine, since it is called only from the environment
340 -- task just before terminating execution.
342 procedure Finalize (V : in out File_IO_Clean_Up_Type) is
343 pragma Warnings (Off, V);
345 Fptr1 : AFCB_Ptr;
346 Fptr2 : AFCB_Ptr;
348 Discard : int;
349 pragma Unreferenced (Discard);
351 begin
352 -- Take a lock to protect global Open_Files data structure
354 SSL.Lock_Task.all;
356 -- First close all open files (the slightly complex form of this loop
357 -- is required because Close as a side effect nulls out its argument)
359 Fptr1 := Open_Files;
360 while Fptr1 /= null loop
361 Fptr2 := Fptr1.Next;
362 Close (Fptr1);
363 Fptr1 := Fptr2;
364 end loop;
366 -- Now unlink all temporary files. We do not bother to free the
367 -- blocks because we are just about to terminate the program. We
368 -- also ignore any errors while attempting these unlink operations.
370 while Temp_Files /= null loop
371 Discard := unlink (Temp_Files.Name'Address);
372 Temp_Files := Temp_Files.Next;
373 end loop;
375 SSL.Unlock_Task.all;
377 exception
378 when others =>
379 SSL.Unlock_Task.all;
380 raise;
381 end Finalize;
383 -----------
384 -- Flush --
385 -----------
387 procedure Flush (File : AFCB_Ptr) is
388 begin
389 Check_Write_Status (File);
391 if fflush (File.Stream) = 0 then
392 return;
393 else
394 raise Device_Error;
395 end if;
396 end Flush;
398 ----------------
399 -- Fopen_Mode --
400 ----------------
402 -- The fopen mode to be used is shown by the following table:
404 -- OPEN CREATE
405 -- Append_File "r+" "w+"
406 -- In_File "r" "w+"
407 -- Out_File (Direct_IO) "r+" "w"
408 -- Out_File (all others) "w" "w"
409 -- Inout_File "r+" "w+"
411 -- Note: we do not use "a" or "a+" for Append_File, since this would not
412 -- work in the case of stream files, where even if in append file mode,
413 -- you can reset to earlier points in the file. The caller must use the
414 -- Append_Set routine to deal with the necessary positioning.
416 -- Note: in several cases, the fopen mode used allows reading and
417 -- writing, but the setting of the Ada mode is more restrictive. For
418 -- instance, Create in In_File mode uses "w+" which allows writing,
419 -- but the Ada mode In_File will cause any write operations to be
420 -- rejected with Mode_Error in any case.
422 -- Note: for the Out_File/Open cases for other than the Direct_IO case,
423 -- an initial call will be made by the caller to first open the file in
424 -- "r" mode to be sure that it exists. The real open, in "w" mode, will
425 -- then destroy this file. This is peculiar, but that's what Ada semantics
426 -- require and the ACVT tests insist on!
428 -- If text file translation is required, then either b or t is
429 -- added to the mode, depending on the setting of Text.
431 procedure Fopen_Mode
432 (Mode : File_Mode;
433 Text : Boolean;
434 Creat : Boolean;
435 Amethod : Character;
436 Fopstr : out Fopen_String)
438 Fptr : Positive;
440 begin
441 case Mode is
442 when In_File =>
443 if Creat then
444 Fopstr (1) := 'w';
445 Fopstr (2) := '+';
446 Fptr := 3;
447 else
448 Fopstr (1) := 'r';
449 Fptr := 2;
450 end if;
452 when Out_File =>
453 if Amethod = 'D' and not Creat then
454 Fopstr (1) := 'r';
455 Fopstr (2) := '+';
456 Fptr := 3;
457 else
458 Fopstr (1) := 'w';
459 Fptr := 2;
460 end if;
462 when Inout_File | Append_File =>
463 if Creat then
464 Fopstr (1) := 'w';
465 else
466 Fopstr (1) := 'r';
467 end if;
469 Fopstr (2) := '+';
470 Fptr := 3;
472 end case;
474 -- If text_translation_required is true then we need to append
475 -- either a t or b to the string to get the right mode
477 if text_translation_required then
478 if Text then
479 Fopstr (Fptr) := 't';
480 else
481 Fopstr (Fptr) := 'b';
482 end if;
484 Fptr := Fptr + 1;
485 end if;
487 Fopstr (Fptr) := ASCII.NUL;
488 end Fopen_Mode;
490 ----------
491 -- Form --
492 ----------
494 function Form (File : AFCB_Ptr) return String is
495 begin
496 if File = null then
497 raise Status_Error;
498 else
499 return File.Form.all (1 .. File.Form'Length - 1);
500 end if;
501 end Form;
503 ------------------
504 -- Form_Boolean --
505 ------------------
507 function Form_Boolean
508 (Form : String;
509 Keyword : String;
510 Default : Boolean)
511 return Boolean
513 V1, V2 : Natural;
515 begin
516 Form_Parameter (Form, Keyword, V1, V2);
518 if V1 = 0 then
519 return Default;
521 elsif Form (V1) = 'y' then
522 return True;
524 elsif Form (V1) = 'n' then
525 return False;
527 else
528 raise Use_Error;
529 end if;
530 end Form_Boolean;
532 ------------------
533 -- Form_Integer --
534 ------------------
536 function Form_Integer
537 (Form : String;
538 Keyword : String;
539 Default : Integer)
540 return Integer
542 V1, V2 : Natural;
543 V : Integer;
545 begin
546 Form_Parameter (Form, Keyword, V1, V2);
548 if V1 = 0 then
549 return Default;
551 else
552 V := 0;
554 for J in V1 .. V2 loop
555 if Form (J) not in '0' .. '9' then
556 raise Use_Error;
557 else
558 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0');
559 end if;
561 if V > 999_999 then
562 raise Use_Error;
563 end if;
564 end loop;
566 return V;
567 end if;
568 end Form_Integer;
570 --------------------
571 -- Form_Parameter --
572 --------------------
574 procedure Form_Parameter
575 (Form : String;
576 Keyword : String;
577 Start : out Natural;
578 Stop : out Natural)
580 Klen : constant Integer := Keyword'Length;
582 -- Start of processing for Form_Parameter
584 begin
585 for J in Form'First + Klen .. Form'Last - 1 loop
586 if Form (J) = '='
587 and then Form (J - Klen .. J - 1) = Keyword
588 then
589 Start := J + 1;
590 Stop := Start - 1;
592 while Form (Stop + 1) /= ASCII.NUL
593 and then Form (Stop + 1) /= ','
594 loop
595 Stop := Stop + 1;
596 end loop;
598 return;
599 end if;
600 end loop;
602 Start := 0;
603 Stop := 0;
604 end Form_Parameter;
606 -------------
607 -- Is_Open --
608 -------------
610 function Is_Open (File : AFCB_Ptr) return Boolean is
611 begin
612 return (File /= null);
613 end Is_Open;
615 -------------------
616 -- Make_Buffered --
617 -------------------
619 procedure Make_Buffered
620 (File : AFCB_Ptr;
621 Buf_Siz : Interfaces.C_Streams.size_t)
623 status : Integer;
624 pragma Unreferenced (status);
626 begin
627 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
628 end Make_Buffered;
630 ------------------------
631 -- Make_Line_Buffered --
632 ------------------------
634 procedure Make_Line_Buffered
635 (File : AFCB_Ptr;
636 Line_Siz : Interfaces.C_Streams.size_t)
638 status : Integer;
639 pragma Unreferenced (status);
641 begin
642 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
643 end Make_Line_Buffered;
645 ---------------------
646 -- Make_Unbuffered --
647 ---------------------
649 procedure Make_Unbuffered (File : AFCB_Ptr) is
650 status : Integer;
651 pragma Unreferenced (status);
653 begin
654 status := setvbuf (File.Stream, Null_Address, IONBF, 0);
655 end Make_Unbuffered;
657 ----------
658 -- Mode --
659 ----------
661 function Mode (File : AFCB_Ptr) return File_Mode is
662 begin
663 if File = null then
664 raise Status_Error;
665 else
666 return File.Mode;
667 end if;
668 end Mode;
670 ----------
671 -- Name --
672 ----------
674 function Name (File : AFCB_Ptr) return String is
675 begin
676 if File = null then
677 raise Status_Error;
678 else
679 return File.Name.all (1 .. File.Name'Length - 1);
680 end if;
681 end Name;
683 ----------
684 -- Open --
685 ----------
687 procedure Open
688 (File_Ptr : in out AFCB_Ptr;
689 Dummy_FCB : AFCB'Class;
690 Mode : File_Mode;
691 Name : String;
692 Form : String;
693 Amethod : Character;
694 Creat : Boolean;
695 Text : Boolean;
696 C_Stream : FILEs := NULL_Stream)
698 pragma Warnings (Off, Dummy_FCB);
699 -- Yes we know this is never assigned a value. That's intended, since
700 -- all we ever use of this value is the tag for dispatching purposes.
702 procedure Tmp_Name (Buffer : Address);
703 pragma Import (C, Tmp_Name, "__gnat_tmp_name");
704 -- set buffer (a String address) with a temporary filename
706 Stream : FILEs := C_Stream;
707 -- Stream which we open in response to this request
709 Shared : Shared_Status_Type;
710 -- Setting of Shared_Status field for file
712 Fopstr : aliased Fopen_String;
713 -- Mode string used in fopen call
715 Formstr : aliased String (1 .. Form'Length + 1);
716 -- Form string with ASCII.NUL appended, folded to lower case
718 Tempfile : constant Boolean := (Name'Length = 0);
719 -- Indicates temporary file case
721 Namelen : constant Integer := max_path_len;
722 -- Length required for file name, not including final ASCII.NUL
723 -- Note that we used to reference L_tmpnam here, which is not
724 -- reliable since __gnat_tmp_name does not always use tmpnam.
726 Namestr : aliased String (1 .. Namelen + 1);
727 -- Name as given or temporary file name with ASCII.NUL appended
729 Fullname : aliased String (1 .. max_path_len + 1);
730 -- Full name (as required for Name function, and as stored in the
731 -- control block in the Name field) with ASCII.NUL appended.
733 Full_Name_Len : Integer;
734 -- Length of name actually stored in Fullname
736 begin
737 if File_Ptr /= null then
738 raise Status_Error;
739 end if;
741 -- Acquire form string, setting required NUL terminator
743 Formstr (1 .. Form'Length) := Form;
744 Formstr (Formstr'Last) := ASCII.NUL;
746 -- Convert form string to lower case
748 for J in Formstr'Range loop
749 if Formstr (J) in 'A' .. 'Z' then
750 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32);
751 end if;
752 end loop;
754 -- Acquire setting of shared parameter
756 declare
757 V1, V2 : Natural;
759 begin
760 Form_Parameter (Formstr, "shared", V1, V2);
762 if V1 = 0 then
763 Shared := None;
765 elsif Formstr (V1 .. V2) = "yes" then
766 Shared := Yes;
768 elsif Formstr (V1 .. V2) = "no" then
769 Shared := No;
771 else
772 raise Use_Error;
773 end if;
774 end;
776 -- If we were given a stream (call from xxx.C_Streams.Open), then set
777 -- the full name to the given one, and skip to end of processing.
779 if Stream /= NULL_Stream then
780 Full_Name_Len := Name'Length + 1;
781 Fullname (1 .. Full_Name_Len - 1) := Name;
782 Fullname (Full_Name_Len) := ASCII.Nul;
784 -- Normal case of Open or Create
786 else
787 -- If temporary file case, get temporary file name and add
788 -- to the list of temporary files to be deleted on exit.
790 if Tempfile then
791 if not Creat then
792 raise Name_Error;
793 end if;
795 Tmp_Name (Namestr'Address);
797 if Namestr (1) = ASCII.NUL then
798 raise Use_Error;
799 end if;
801 -- Chain to temp file list, ensuring thread safety with a lock
803 begin
804 SSL.Lock_Task.all;
805 Temp_Files :=
806 new Temp_File_Record'(Name => Namestr, Next => Temp_Files);
807 SSL.Unlock_Task.all;
809 exception
810 when others =>
811 SSL.Unlock_Task.all;
812 raise;
813 end;
815 -- Normal case of non-null name given
817 else
818 if Name'Length > Namelen then
819 raise Name_Error;
820 end if;
822 Namestr (1 .. Name'Length) := Name;
823 Namestr (Name'Length + 1) := ASCII.NUL;
824 end if;
826 -- Get full name in accordance with the advice of RM A.8.2(22)
828 full_name (Namestr'Address, Fullname'Address);
830 if Fullname (1) = ASCII.NUL then
831 raise Use_Error;
832 end if;
834 Full_Name_Len := 1;
835 while Full_Name_Len < Fullname'Last
836 and then Fullname (Full_Name_Len) /= ASCII.NUL
837 loop
838 Full_Name_Len := Full_Name_Len + 1;
839 end loop;
841 -- If Shared=None or Shared=Yes, then check for the existence
842 -- of another file with exactly the same full name.
844 if Shared /= No then
845 declare
846 P : AFCB_Ptr;
848 begin
849 -- Take a task lock to protect Open_Files
851 SSL.Lock_Task.all;
853 -- Search list of open files
855 P := Open_Files;
856 while P /= null loop
857 if Fullname (1 .. Full_Name_Len) = P.Name.all then
859 -- If we get a match, and either file has Shared=None,
860 -- then raise Use_Error, since we don't allow two
861 -- files of the same name to be opened unless they
862 -- specify the required sharing mode.
864 if Shared = None
865 or else P.Shared_Status = None
866 then
867 raise Use_Error;
869 -- If both files have Shared=Yes, then we acquire the
870 -- stream from the located file to use as our stream.
872 elsif Shared = Yes
873 and then P.Shared_Status = Yes
874 then
875 Stream := P.Stream;
876 exit;
878 -- Otherwise one of the files has Shared=Yes and one
879 -- has Shared=No. If the current file has Shared=No
880 -- then all is well but we don't want to share any
881 -- other file's stream. If the current file has
882 -- Shared=Yes, we would like to share a stream, but
883 -- not from a file that has Shared=No, so in either
884 -- case we just keep going on the search.
886 else
887 null;
888 end if;
889 end if;
891 P := P.Next;
892 end loop;
894 SSL.Unlock_Task.all;
896 exception
897 when others =>
898 SSL.Unlock_Task.all;
899 raise;
900 end;
901 end if;
903 -- Open specified file if we did not find an existing stream
905 if Stream = NULL_Stream then
906 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr);
908 -- A special case, if we are opening (OPEN case) a file and
909 -- the mode returned by Fopen_Mode is not "r" or "r+", then
910 -- we first make sure that the file exists as required by
911 -- Ada semantics.
913 if Creat = False and then Fopstr (1) /= 'r' then
914 if file_exists (Namestr'Address) = 0 then
915 raise Name_Error;
916 end if;
917 end if;
919 -- Now open the file. Note that we use the name as given
920 -- in the original Open call for this purpose, since that
921 -- seems the clearest implementation of the intent. It
922 -- would presumably work to use the full name here, but
923 -- if there is any difference, then we should use the
924 -- name used in the call.
926 -- Note: for a corresponding delete, we will use the
927 -- full name, since by the time of the delete, the
928 -- current working directory may have changed and
929 -- we do not want to delete a different file!
931 Stream := fopen (Namestr'Address, Fopstr'Address);
933 if Stream = NULL_Stream then
934 if file_exists (Namestr'Address) = 0 then
935 raise Name_Error;
936 else
937 raise Use_Error;
938 end if;
939 end if;
940 end if;
941 end if;
943 -- Stream has been successfully located or opened, so now we are
944 -- committed to completing the opening of the file. Allocate block
945 -- on heap and fill in its fields.
947 File_Ptr := AFCB_Allocate (Dummy_FCB);
949 File_Ptr.Is_Regular_File := (is_regular_file
950 (fileno (Stream)) /= 0);
951 File_Ptr.Is_System_File := False;
952 File_Ptr.Is_Text_File := Text;
953 File_Ptr.Shared_Status := Shared;
954 File_Ptr.Access_Method := Amethod;
955 File_Ptr.Stream := Stream;
956 File_Ptr.Form := new String'(Formstr);
957 File_Ptr.Name := new String'(Fullname
958 (1 .. Full_Name_Len));
959 File_Ptr.Mode := Mode;
960 File_Ptr.Is_Temporary_File := Tempfile;
962 Chain_File (File_Ptr);
963 Append_Set (File_Ptr);
964 end Open;
966 --------------
967 -- Read_Buf --
968 --------------
970 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
971 Nread : size_t;
973 begin
974 Nread := fread (Buf, 1, Siz, File.Stream);
976 if Nread = Siz then
977 return;
979 elsif ferror (File.Stream) /= 0 then
980 raise Device_Error;
982 elsif Nread = 0 then
983 raise End_Error;
985 else -- 0 < Nread < Siz
986 raise Data_Error;
987 end if;
989 end Read_Buf;
991 procedure Read_Buf
992 (File : AFCB_Ptr;
993 Buf : Address;
994 Siz : Interfaces.C_Streams.size_t;
995 Count : out Interfaces.C_Streams.size_t)
997 begin
998 Count := fread (Buf, 1, Siz, File.Stream);
1000 if Count = 0 and then ferror (File.Stream) /= 0 then
1001 raise Device_Error;
1002 end if;
1003 end Read_Buf;
1005 -----------
1006 -- Reset --
1007 -----------
1009 -- The reset which does not change the mode simply does a rewind
1011 procedure Reset (File : in out AFCB_Ptr) is
1012 begin
1013 Check_File_Open (File);
1014 Reset (File, File.Mode);
1015 end Reset;
1017 -- The reset with a change in mode is done using freopen, and is
1018 -- not permitted except for regular files (since otherwise there
1019 -- is no name for the freopen, and in any case it seems meaningless)
1021 procedure Reset (File : in out AFCB_Ptr; Mode : File_Mode) is
1022 Fopstr : aliased Fopen_String;
1024 begin
1025 Check_File_Open (File);
1027 -- Change of mode not allowed for shared file or file with no name
1028 -- or file that is not a regular file, or for a system file.
1030 if File.Shared_Status = Yes
1031 or else File.Name'Length <= 1
1032 or else File.Is_System_File
1033 or else (not File.Is_Regular_File)
1034 then
1035 raise Use_Error;
1037 -- For In_File or Inout_File for a regular file, we can just do a
1038 -- rewind if the mode is unchanged, which is more efficient than
1039 -- doing a full reopen.
1041 elsif Mode = File.Mode
1042 and then Mode <= Inout_File
1043 then
1044 rewind (File.Stream);
1046 -- Here the change of mode is permitted, we do it by reopening the
1047 -- file in the new mode and replacing the stream with a new stream.
1049 else
1050 Fopen_Mode
1051 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
1053 File.Stream :=
1054 freopen (File.Name.all'Address, Fopstr'Address, File.Stream);
1056 if File.Stream = NULL_Stream then
1057 Close (File);
1058 raise Use_Error;
1060 else
1061 File.Mode := Mode;
1062 Append_Set (File);
1063 end if;
1064 end if;
1065 end Reset;
1067 ---------------
1068 -- Write_Buf --
1069 ---------------
1071 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1072 begin
1073 -- Note: for most purposes, the Siz and 1 parameters in the fwrite
1074 -- call could be reversed, but on VMS, this is a better choice, since
1075 -- for some file formats, reversing the parameters results in records
1076 -- of one byte each.
1078 SSL.Abort_Defer.all;
1080 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then
1081 if Siz /= 0 then
1082 SSL.Abort_Undefer.all;
1083 raise Device_Error;
1084 end if;
1085 end if;
1087 SSL.Abort_Undefer.all;
1088 end Write_Buf;
1090 end System.File_IO;