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