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