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