File : s-fileio.adb


   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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31 
  32 with Ada.Finalization;           use Ada.Finalization;
  33 with Ada.IO_Exceptions;          use Ada.IO_Exceptions;
  34 with Ada.Unchecked_Deallocation;
  35 
  36 with Interfaces.C;
  37 with Interfaces.C_Streams;       use Interfaces.C_Streams;
  38 
  39 with System.Case_Util;           use System.Case_Util;
  40 with System.CRTL;
  41 with System.OS_Lib;
  42 with System.Soft_Links;
  43 
  44 package body System.File_IO is
  45 
  46    use System.File_Control_Block;
  47 
  48    package SSL renames System.Soft_Links;
  49 
  50    use type CRTL.size_t;
  51    use type Interfaces.C.int;
  52 
  53    ----------------------
  54    -- Global Variables --
  55    ----------------------
  56 
  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.
  62 
  63    type Temp_File_Record;
  64    type Temp_File_Record_Ptr is access all Temp_File_Record;
  65 
  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
  71 
  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.
  75 
  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.
  83 
  84    procedure Finalize (V : in out File_IO_Clean_Up_Type);
  85    --  This is the finalize operation that is used to do the cleanup
  86 
  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.
  92 
  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
  98 
  99    -----------------------
 100    -- Local Subprograms --
 101    -----------------------
 102 
 103    procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring);
 104 
 105    subtype Fopen_String is String (1 .. 4);
 106    --  Holds open string (longest is "w+b" & nul)
 107 
 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.
 121 
 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
 126 
 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.
 133 
 134    ----------------
 135    -- Append_Set --
 136    ----------------
 137 
 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;
 146 
 147    ----------------
 148    -- Chain_File --
 149    ----------------
 150 
 151    procedure Chain_File (File : AFCB_Ptr) is
 152    begin
 153       --  Take a task lock, to protect the global data value Open_Files
 154 
 155       SSL.Lock_Task.all;
 156 
 157       --  Do the chaining operation locked
 158 
 159       File.Next := Open_Files;
 160       File.Prev := null;
 161       Open_Files := File;
 162 
 163       if File.Next /= null then
 164          File.Next.Prev := File;
 165       end if;
 166 
 167       SSL.Unlock_Task.all;
 168 
 169    exception
 170       when others =>
 171          SSL.Unlock_Task.all;
 172          raise;
 173    end Chain_File;
 174 
 175    ---------------------
 176    -- Check_File_Open --
 177    ---------------------
 178 
 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;
 185 
 186    -----------------------
 187    -- Check_Read_Status --
 188    -----------------------
 189 
 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;
 198 
 199    ------------------------
 200    -- Check_Write_Status --
 201    ------------------------
 202 
 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;
 211 
 212    -----------
 213    -- Close --
 214    -----------
 215 
 216    procedure Close (File_Ptr : access AFCB_Ptr) is
 217       Close_Status : int     := 0;
 218       Dup_Strm     : Boolean := False;
 219       Errno        : Integer := 0;
 220 
 221       File : AFCB_Ptr renames File_Ptr.all;
 222 
 223    begin
 224       --  Take a task lock, to protect the global data value Open_Files
 225 
 226       SSL.Lock_Task.all;
 227 
 228       Check_File_Open (File);
 229       AFCB_Close (File);
 230 
 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).
 236 
 237       if not File.Is_System_File and then File.Stream /= NULL_Stream then
 238 
 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.
 241 
 242          if File.Shared_Status = Yes then
 243             declare
 244                P   : AFCB_Ptr;
 245 
 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;
 253 
 254                   P := P.Next;
 255                end loop;
 256             end;
 257          end if;
 258 
 259          --  Do the fclose unless this was a duplicate in the shared case
 260 
 261          if not Dup_Strm then
 262             Close_Status := fclose (File.Stream);
 263 
 264             if Close_Status /= 0 then
 265                Errno := OS_Lib.Errno;
 266             end if;
 267          end if;
 268       end if;
 269 
 270       --  Dechain file from list of open files and then free the storage
 271 
 272       if File.Prev = null then
 273          Open_Files := File.Next;
 274       else
 275          File.Prev.Next := File.Next;
 276       end if;
 277 
 278       if File.Next /= null then
 279          File.Next.Prev := File.Prev;
 280       end if;
 281 
 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.
 285 
 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;
 291 
 292       File := null;
 293 
 294       if Close_Status /= 0 then
 295          Raise_Device_Error (null, Errno);
 296       end if;
 297 
 298       SSL.Unlock_Task.all;
 299 
 300    exception
 301       when others =>
 302          SSL.Unlock_Task.all;
 303          raise;
 304    end Close;
 305 
 306    ------------
 307    -- Delete --
 308    ------------
 309 
 310    procedure Delete (File_Ptr : access AFCB_Ptr) is
 311       File : AFCB_Ptr renames File_Ptr.all;
 312 
 313    begin
 314       Check_File_Open (File);
 315 
 316       if not File.Is_Regular_File then
 317          raise Use_Error with "cannot delete non-regular file";
 318       end if;
 319 
 320       declare
 321          Filename : aliased constant String := File.Name.all;
 322 
 323       begin
 324          Close (File_Ptr);
 325 
 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.
 329 
 330          if unlink (Filename'Address) = -1 then
 331             raise Use_Error with OS_Lib.Errno_Message;
 332          end if;
 333       end;
 334    end Delete;
 335 
 336    -----------------
 337    -- End_Of_File --
 338    -----------------
 339 
 340    function End_Of_File (File : AFCB_Ptr) return Boolean is
 341    begin
 342       Check_File_Open (File);
 343 
 344       if feof (File.Stream) /= 0 then
 345          return True;
 346 
 347       else
 348          Check_Read_Status (File);
 349 
 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;
 358 
 359    -------------------
 360    -- Errno_Message --
 361    -------------------
 362 
 363    function Errno_Message
 364      (Name  : String;
 365       Errno : Integer := OS_Lib.Errno) return String
 366    is
 367    begin
 368       return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
 369    end Errno_Message;
 370 
 371    --------------
 372    -- Finalize --
 373    --------------
 374 
 375    procedure Finalize (V : in out File_IO_Clean_Up_Type) is
 376       pragma Warnings (Off, V);
 377 
 378       Fptr1   : aliased AFCB_Ptr;
 379       Fptr2   : AFCB_Ptr;
 380 
 381       Discard : int;
 382 
 383    begin
 384       --  Take a lock to protect global Open_Files data structure
 385 
 386       SSL.Lock_Task.all;
 387 
 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).
 390 
 391       Fptr1 := Open_Files;
 392       while Fptr1 /= null loop
 393          Fptr2 := Fptr1.Next;
 394          Close (Fptr1'Access);
 395          Fptr1 := Fptr2;
 396       end loop;
 397 
 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.
 401 
 402       while Temp_Files /= null loop
 403          Discard := unlink (Temp_Files.Name'Address);
 404          Temp_Files := Temp_Files.Next;
 405       end loop;
 406 
 407       SSL.Unlock_Task.all;
 408 
 409    exception
 410       when others =>
 411          SSL.Unlock_Task.all;
 412          raise;
 413    end Finalize;
 414 
 415    -----------
 416    -- Flush --
 417    -----------
 418 
 419    procedure Flush (File : AFCB_Ptr) is
 420    begin
 421       Check_Write_Status (File);
 422 
 423       if fflush (File.Stream) /= 0 then
 424          Raise_Device_Error (File);
 425       end if;
 426    end Flush;
 427 
 428    ----------------
 429    -- Fopen_Mode --
 430    ----------------
 431 
 432    --  The fopen mode to be used is shown by the following table:
 433 
 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+"
 440 
 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.
 444 
 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.
 449 
 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.
 455 
 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.
 461 
 462    --  If text file translation is required, then either "b" or "t" is appended
 463    --  to the mode, depending on the setting of Text.
 464 
 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)
 472    is
 473       Fptr : Positive;
 474 
 475       function is_fifo (Path : Address) return Integer;
 476       pragma Import (C, is_fifo, "__gnat_is_fifo");
 477 
 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;
 489 
 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;
 502 
 503          when Inout_File | Append_File =>
 504             Fopstr (1) := (if Creat then 'w' else 'r');
 505             Fopstr (2) := '+';
 506             Fptr := 3;
 507       end case;
 508 
 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.
 511 
 512       if text_translation_required then
 513          Fopstr (Fptr) := (if Text then 't' else 'b');
 514          Fptr := Fptr + 1;
 515       end if;
 516 
 517       Fopstr (Fptr) := ASCII.NUL;
 518    end Fopen_Mode;
 519 
 520    ----------
 521    -- Form --
 522    ----------
 523 
 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;
 532 
 533    ------------------
 534    -- Form_Boolean --
 535    ------------------
 536 
 537    function Form_Boolean
 538      (Form    : String;
 539       Keyword : String;
 540       Default : Boolean) return Boolean
 541    is
 542       V1, V2 : Natural;
 543       pragma Unreferenced (V2);
 544 
 545    begin
 546       Form_Parameter (Form, Keyword, V1, V2);
 547 
 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;
 558 
 559    ------------------
 560    -- Form_Integer --
 561    ------------------
 562 
 563    function Form_Integer
 564      (Form    : String;
 565       Keyword : String;
 566       Default : Integer) return Integer
 567    is
 568       V1, V2 : Natural;
 569       V      : Integer;
 570 
 571    begin
 572       Form_Parameter (Form, Keyword, V1, V2);
 573 
 574       if V1 = 0 then
 575          return Default;
 576 
 577       else
 578          V := 0;
 579 
 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;
 586 
 587             if V > 999_999 then
 588                raise Use_Error with "invalid Form";
 589             end if;
 590          end loop;
 591 
 592          return V;
 593       end if;
 594    end Form_Integer;
 595 
 596    --------------------
 597    -- Form_Parameter --
 598    --------------------
 599 
 600    procedure Form_Parameter
 601      (Form    : String;
 602       Keyword : String;
 603       Start   : out Natural;
 604       Stop    : out Natural)
 605    is
 606       Klen : constant Integer := Keyword'Length;
 607 
 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;
 620 
 621             return;
 622          end if;
 623       end loop;
 624 
 625       Start := 0;
 626       Stop  := 0;
 627    end Form_Parameter;
 628 
 629    -------------
 630    -- Is_Open --
 631    -------------
 632 
 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.
 640 
 641       return File /= null and then fileno (File.Stream) /= -1;
 642    end Is_Open;
 643 
 644    -------------------
 645    -- Make_Buffered --
 646    -------------------
 647 
 648    procedure Make_Buffered
 649      (File    : AFCB_Ptr;
 650       Buf_Siz : Interfaces.C_Streams.size_t)
 651    is
 652       status : Integer;
 653       pragma Unreferenced (status);
 654 
 655    begin
 656       status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
 657    end Make_Buffered;
 658 
 659    ------------------------
 660    -- Make_Line_Buffered --
 661    ------------------------
 662 
 663    procedure Make_Line_Buffered
 664      (File     : AFCB_Ptr;
 665       Line_Siz : Interfaces.C_Streams.size_t)
 666    is
 667       status : Integer;
 668       pragma Unreferenced (status);
 669 
 670    begin
 671       status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
 672       --  No error checking???
 673    end Make_Line_Buffered;
 674 
 675    ---------------------
 676    -- Make_Unbuffered --
 677    ---------------------
 678 
 679    procedure Make_Unbuffered (File : AFCB_Ptr) is
 680       status : Integer;
 681       pragma Unreferenced (status);
 682 
 683    begin
 684       status := setvbuf (File.Stream, Null_Address, IONBF, 0);
 685       --  No error checking???
 686    end Make_Unbuffered;
 687 
 688    ----------
 689    -- Mode --
 690    ----------
 691 
 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;
 700 
 701    ----------
 702    -- Name --
 703    ----------
 704 
 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;
 713 
 714    ----------
 715    -- Open --
 716    ----------
 717 
 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)
 728    is
 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.
 732 
 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
 736 
 737       function Get_Case_Sensitive return Integer;
 738       pragma Import (C, Get_Case_Sensitive,
 739                      "__gnat_get_file_names_case_sensitive");
 740 
 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.
 745 
 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.
 752 
 753       Stream : FILEs := C_Stream;
 754       --  Stream which we open in response to this request
 755 
 756       Shared : Shared_Status_Type;
 757       --  Setting of Shared_Status field for file
 758 
 759       Fopstr : aliased Fopen_String;
 760       --  Mode string used in fopen call
 761 
 762       Formstr : aliased String (1 .. Form'Length + 1);
 763       --  Form string with ASCII.NUL appended, folded to lower case
 764 
 765       Text_Encoding : Content_Encoding;
 766 
 767       Tempfile : constant Boolean := (Name'Length = 0);
 768       --  Indicates temporary file case
 769 
 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.
 774 
 775       Namestr : aliased String (1 .. Namelen + 1);
 776       --  Name as given or temporary file name with ASCII.NUL appended
 777 
 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.
 781 
 782       Full_Name_Len : Integer;
 783       --  Length of name actually stored in Fullname
 784 
 785       Encoding : CRTL.Filename_Encoding;
 786       --  Filename encoding specified into the form parameter
 787 
 788       -----------------
 789       -- Record_AFCB --
 790       -----------------
 791 
 792       procedure Record_AFCB is
 793       begin
 794          File_Ptr := AFCB_Allocate (Dummy_FCB);
 795 
 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).
 798 
 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;
 811 
 812          Chain_File (File_Ptr);
 813          Append_Set (File_Ptr);
 814       end Record_AFCB;
 815 
 816    --  Start of processing for Open
 817 
 818    begin
 819       if File_Ptr /= null then
 820          raise Status_Error with "file already open";
 821       end if;
 822 
 823       --  Acquire form string, setting required NUL terminator
 824 
 825       Formstr (1 .. Form'Length) := Form;
 826       Formstr (Formstr'Last) := ASCII.NUL;
 827 
 828       --  Convert form string to lower case
 829 
 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;
 835 
 836       --  Acquire setting of shared parameter
 837 
 838       declare
 839          V1, V2 : Natural;
 840 
 841       begin
 842          Form_Parameter (Formstr, "shared", V1, V2);
 843 
 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;
 854 
 855       --  Acquire setting of encoding parameter
 856 
 857       declare
 858          V1, V2 : Natural;
 859 
 860       begin
 861          Form_Parameter (Formstr, "encoding", V1, V2);
 862 
 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;
 873 
 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.
 878 
 879       if Text then
 880          Text_Encoding := Default_Text;
 881       else
 882          Text_Encoding := None;
 883       end if;
 884 
 885       if Text_Encoding in Text_Content_Encoding then
 886          declare
 887             V1, V2 : Natural;
 888 
 889          begin
 890             Form_Parameter (Formstr, "text_translation", V1, V2);
 891 
 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;
 911 
 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.
 914 
 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;
 919 
 920       --  Normal case of Open or Create
 921 
 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.
 925 
 926          if Tempfile then
 927             if not Creat then
 928                raise Name_Error with "opening temp file without creating it";
 929             end if;
 930 
 931             Tmp_Name (Namestr'Address);
 932 
 933             if Namestr (1) = ASCII.NUL then
 934                raise Use_Error with "invalid temp file name";
 935             end if;
 936 
 937             --  Chain to temp file list, ensuring thread safety with a lock
 938 
 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;
 944 
 945             exception
 946                when others =>
 947                   SSL.Unlock_Task.all;
 948                   raise;
 949             end;
 950 
 951          --  Normal case of non-null name given
 952 
 953          else
 954             if Name'Length > Namelen then
 955                raise Name_Error with "file name too long";
 956             end if;
 957 
 958             Namestr (1 .. Name'Length) := Name;
 959             Namestr (Name'Length + 1)  := ASCII.NUL;
 960          end if;
 961 
 962          --  Get full name in accordance with the advice of RM A.8.2(22)
 963 
 964          full_name (Namestr'Address, Fullname'Address);
 965 
 966          if Fullname (1) = ASCII.NUL then
 967             raise Use_Error with Errno_Message (Name);
 968          end if;
 969 
 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;
 976 
 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.
 983 
 984          if not File_Names_Case_Sensitive then
 985             To_Lower (Fullname (1 .. Full_Name_Len));
 986          end if;
 987 
 988          --  If Shared=None or Shared=Yes, then check for the existence of
 989          --  another file with exactly the same full name.
 990 
 991          if Shared /= No then
 992             declare
 993                P : AFCB_Ptr;
 994 
 995             begin
 996                --  Take a task lock to protect Open_Files
 997 
 998                SSL.Lock_Task.all;
 999 
1000                --  Search list of open files
1001 
1002                P := Open_Files;
1003                while P /= null loop
1004                   if Fullname (1 .. Full_Name_Len) = P.Name.all then
1005 
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.
1010 
1011                      if Shared = None
1012                        or else P.Shared_Status = None
1013                      then
1014                         raise Use_Error with "reopening shared file";
1015 
1016                      --  If both files have Shared=Yes, then we acquire the
1017                      --  stream from the located file to use as our stream.
1018 
1019                      elsif Shared = Yes
1020                        and then P.Shared_Status = Yes
1021                      then
1022                         Stream := P.Stream;
1023 
1024                         Record_AFCB;
1025 
1026                         exit;
1027 
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.
1034 
1035                      else
1036                         null;
1037                      end if;
1038                   end if;
1039 
1040                   P := P.Next;
1041                end loop;
1042 
1043                SSL.Unlock_Task.all;
1044 
1045             exception
1046                when others =>
1047                   SSL.Unlock_Task.all;
1048                   raise;
1049             end;
1050          end if;
1051 
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.
1054 
1055          if Stream /= NULL_Stream then
1056             return;
1057 
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);
1066 
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.
1070 
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;
1076 
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.
1082 
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.
1086 
1087             Stream :=
1088               fopen (Namestr'Address, Fopstr'Address, Encoding);
1089 
1090             if Stream = NULL_Stream then
1091 
1092                --  Raise Name_Error if trying to open a non-existent file.
1093                --  Otherwise raise Use_Error.
1094 
1095                --  Should we raise Device_Error for ENOSPC???
1096 
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.
1105 
1106                   Errno   : constant Integer := OS_Lib.Errno;
1107                   Message : constant String := Errno_Message (Name, Errno);
1108 
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;
1119 
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.
1123 
1124       Record_AFCB;
1125    end Open;
1126 
1127    ------------------------
1128    -- Raise_Device_Error --
1129    ------------------------
1130 
1131    procedure Raise_Device_Error
1132      (File  : AFCB_Ptr;
1133       Errno : Integer := OS_Lib.Errno)
1134    is
1135    begin
1136       --  Clear error status so that the same error is not reported twice
1137 
1138       if File /= null then
1139          clearerr (File.Stream);
1140       end if;
1141 
1142       raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
1143    end Raise_Device_Error;
1144 
1145    --------------
1146    -- Read_Buf --
1147    --------------
1148 
1149    procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
1150       Nread : size_t;
1151 
1152    begin
1153       Nread := fread (Buf, 1, Siz, File.Stream);
1154 
1155       if Nread = Siz then
1156          return;
1157 
1158       elsif ferror (File.Stream) /= 0 then
1159          Raise_Device_Error (File);
1160 
1161       elsif Nread = 0 then
1162          raise End_Error;
1163 
1164       else -- 0 < Nread < Siz
1165          raise Data_Error with "not enough data read";
1166       end if;
1167    end Read_Buf;
1168 
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)
1174    is
1175    begin
1176       Count := fread (Buf, 1, Siz, File.Stream);
1177 
1178       if Count = 0 and then ferror (File.Stream) /= 0 then
1179          Raise_Device_Error (File);
1180       end if;
1181    end Read_Buf;
1182 
1183    -----------
1184    -- Reset --
1185    -----------
1186 
1187    --  The reset which does not change the mode simply does a rewind
1188 
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;
1195 
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).
1199 
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;
1203 
1204    begin
1205       Check_File_Open (File);
1206 
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.
1210 
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;
1222 
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.
1226 
1227       if Mode = File.Mode
1228         and then Mode in Read_File_Mode
1229       then
1230          rewind (File.Stream);
1231 
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.
1234 
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);
1243 
1244          File.Stream := freopen
1245            (File.Name.all'Address, Fopstr'Address, File.Stream,
1246             File.Encoding);
1247 
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;
1257 
1258    ---------------
1259    -- Write_Buf --
1260    ---------------
1261 
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.
1268 
1269       SSL.Abort_Defer.all;
1270 
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;
1277 
1278       SSL.Abort_Undefer.all;
1279    end Write_Buf;
1280 
1281 end System.File_IO;