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-2013, 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_Streams; use Interfaces.C_Streams; 37 38with System.CRTL; 39with System.Case_Util; use System.Case_Util; 40with System.OS_Lib; 41with System.Soft_Links; 42 43with Ada.Unchecked_Deallocation; 44 45package body System.File_IO is 46 47 use System.File_Control_Block; 48 49 package SSL renames System.Soft_Links; 50 51 use type Interfaces.C.int; 52 use type CRTL.size_t; 53 54 subtype String_Access is System.OS_Lib.String_Access; 55 procedure Free (X : in out String_Access) renames System.OS_Lib.Free; 56 57 function "=" (X, Y : String_Access) return Boolean 58 renames System.OS_Lib."="; 59 60 ---------------------- 61 -- Global Variables -- 62 ---------------------- 63 64 Open_Files : AFCB_Ptr; 65 -- This points to a list of AFCB's for all open files. This is a doubly 66 -- linked list, with the Prev pointer of the first entry, and the Next 67 -- pointer of the last entry containing null. Note that this global 68 -- variable must be properly protected to provide thread safety. 69 70 type Temp_File_Record; 71 type Temp_File_Record_Ptr is access all Temp_File_Record; 72 73 type Temp_File_Record is record 74 Name : String (1 .. max_path_len + 1); 75 Next : Temp_File_Record_Ptr; 76 end record; 77 -- One of these is allocated for each temporary file created 78 79 Temp_Files : Temp_File_Record_Ptr; 80 -- Points to list of names of temporary files. Note that this global 81 -- variable must be properly protected to provide thread safety. 82 83 type File_IO_Clean_Up_Type is new Limited_Controlled with null record; 84 -- The closing of all open files and deletion of temporary files is an 85 -- action that takes place at the end of execution of the main program. 86 -- This action is implemented using a library level object which gets 87 -- finalized at the end of program execution. Note that the type is 88 -- limited, in order to stop the compiler optimizing away the declaration 89 -- which would be allowed in the non-limited case. 90 91 procedure Finalize (V : in out File_IO_Clean_Up_Type); 92 -- This is the finalize operation that is used to do the cleanup 93 94 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; 95 pragma Warnings (Off, File_IO_Clean_Up_Object); 96 -- This is the single object of the type that triggers the finalization 97 -- call. Since it is at the library level, this happens just before the 98 -- environment task is finalized. 99 100 text_translation_required : Boolean; 101 for text_translation_required'Size use Character'Size; 102 pragma Import 103 (C, text_translation_required, "__gnat_text_translation_required"); 104 -- If true, add appropriate suffix to control string for Open 105 106 VMS_Formstr : String_Access := null; 107 -- For special VMS RMS keywords and values 108 109 ----------------------- 110 -- Local Subprograms -- 111 ----------------------- 112 113 procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring); 114 115 subtype Fopen_String is String (1 .. 4); 116 -- Holds open string (longest is "w+b" & nul) 117 118 procedure Fopen_Mode 119 (Mode : File_Mode; 120 Text : Boolean; 121 Creat : Boolean; 122 Amethod : Character; 123 Fopstr : out Fopen_String); 124 -- Determines proper open mode for a file to be opened in the given 125 -- Ada mode. Text is true for a text file and false otherwise, and 126 -- Creat is true for a create call, and False for an open call. The 127 -- value stored in Fopstr is a nul-terminated string suitable for a 128 -- call to fopen or freopen. Amethod is the character designating 129 -- the access method from the Access_Method field of the FCB. 130 131 function Errno_Message 132 (Name : String; 133 Errno : Integer := OS_Lib.Errno) return String; 134 -- Return Errno_Message for Errno, with file name prepended 135 136 procedure Raise_Device_Error 137 (File : AFCB_Ptr; 138 Errno : Integer := OS_Lib.Errno); 139 pragma No_Return (Raise_Device_Error); 140 -- Clear error indication on File and raise Device_Error with an exception 141 -- message providing errno information. 142 143 procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access); 144 -- Parse the RMS Keys 145 146 function Form_RMS_Context_Key 147 (Form : String; 148 VMS_Form : String_Access) return Natural; 149 -- Parse the RMS Context Key 150 151 ---------------- 152 -- Append_Set -- 153 ---------------- 154 155 procedure Append_Set (File : AFCB_Ptr) is 156 begin 157 if File.Mode = Append_File then 158 if fseek (File.Stream, 0, SEEK_END) /= 0 then 159 Raise_Device_Error (File); 160 end if; 161 end if; 162 end Append_Set; 163 164 ---------------- 165 -- Chain_File -- 166 ---------------- 167 168 procedure Chain_File (File : AFCB_Ptr) is 169 begin 170 -- Take a task lock, to protect the global data value Open_Files 171 172 SSL.Lock_Task.all; 173 174 -- Do the chaining operation locked 175 176 File.Next := Open_Files; 177 File.Prev := null; 178 Open_Files := File; 179 180 if File.Next /= null then 181 File.Next.Prev := File; 182 end if; 183 184 SSL.Unlock_Task.all; 185 186 exception 187 when others => 188 SSL.Unlock_Task.all; 189 raise; 190 end Chain_File; 191 192 --------------------- 193 -- Check_File_Open -- 194 --------------------- 195 196 procedure Check_File_Open (File : AFCB_Ptr) is 197 begin 198 if File = null then 199 raise Status_Error with "file not open"; 200 end if; 201 end Check_File_Open; 202 203 ----------------------- 204 -- Check_Read_Status -- 205 ----------------------- 206 207 procedure Check_Read_Status (File : AFCB_Ptr) is 208 begin 209 if File = null then 210 raise Status_Error with "file not open"; 211 elsif File.Mode not in Read_File_Mode then 212 raise Mode_Error with "file not readable"; 213 end if; 214 end Check_Read_Status; 215 216 ------------------------ 217 -- Check_Write_Status -- 218 ------------------------ 219 220 procedure Check_Write_Status (File : AFCB_Ptr) is 221 begin 222 if File = null then 223 raise Status_Error with "file not open"; 224 elsif File.Mode = In_File then 225 raise Mode_Error with "file not writable"; 226 end if; 227 end Check_Write_Status; 228 229 ----------- 230 -- Close -- 231 ----------- 232 233 procedure Close (File_Ptr : access AFCB_Ptr) is 234 Close_Status : int := 0; 235 Dup_Strm : Boolean := False; 236 File : AFCB_Ptr renames File_Ptr.all; 237 Errno : Integer := 0; 238 239 begin 240 -- Take a task lock, to protect the global data value Open_Files 241 242 SSL.Lock_Task.all; 243 244 Check_File_Open (File); 245 AFCB_Close (File); 246 247 -- Sever the association between the given file and its associated 248 -- external file. The given file is left closed. Do not perform system 249 -- closes on the standard input, output and error files and also do not 250 -- attempt to close a stream that does not exist (signalled by a null 251 -- stream value -- happens in some error situations). 252 253 if not File.Is_System_File and then File.Stream /= NULL_Stream then 254 255 -- Do not do an fclose if this is a shared file and there is at least 256 -- one other instance of the stream that is open. 257 258 if File.Shared_Status = Yes then 259 declare 260 P : AFCB_Ptr; 261 262 begin 263 P := Open_Files; 264 while P /= null loop 265 if P /= File and then File.Stream = P.Stream then 266 Dup_Strm := True; 267 exit; 268 end if; 269 270 P := P.Next; 271 end loop; 272 end; 273 end if; 274 275 -- Do the fclose unless this was a duplicate in the shared case 276 277 if not Dup_Strm then 278 Close_Status := fclose (File.Stream); 279 280 if Close_Status /= 0 then 281 Errno := OS_Lib.Errno; 282 end if; 283 end if; 284 end if; 285 286 -- Dechain file from list of open files and then free the storage 287 288 if File.Prev = null then 289 Open_Files := File.Next; 290 else 291 File.Prev.Next := File.Next; 292 end if; 293 294 if File.Next /= null then 295 File.Next.Prev := File.Prev; 296 end if; 297 298 -- Deallocate some parts of the file structure that were kept in heap 299 -- storage with the exception of system files (standard input, output 300 -- and error) since they had some information allocated in the stack. 301 302 if not File.Is_System_File then 303 Free_String (File.Name); 304 Free_String (File.Form); 305 AFCB_Free (File); 306 end if; 307 308 File := null; 309 310 if Close_Status /= 0 then 311 Raise_Device_Error (null, Errno); 312 end if; 313 314 SSL.Unlock_Task.all; 315 316 exception 317 when others => 318 SSL.Unlock_Task.all; 319 raise; 320 end Close; 321 322 ------------ 323 -- Delete -- 324 ------------ 325 326 procedure Delete (File_Ptr : access AFCB_Ptr) is 327 File : AFCB_Ptr renames File_Ptr.all; 328 329 begin 330 Check_File_Open (File); 331 332 if not File.Is_Regular_File then 333 raise Use_Error with "cannot delete non-regular file"; 334 end if; 335 336 declare 337 Filename : aliased constant String := File.Name.all; 338 339 begin 340 Close (File_Ptr); 341 342 -- Now unlink the external file. Note that we use the full name in 343 -- this unlink, because the working directory may have changed since 344 -- we did the open, and we want to unlink the right file. 345 346 if unlink (Filename'Address) = -1 then 347 raise Use_Error with OS_Lib.Errno_Message; 348 end if; 349 end; 350 end Delete; 351 352 ----------------- 353 -- End_Of_File -- 354 ----------------- 355 356 function End_Of_File (File : AFCB_Ptr) return Boolean is 357 begin 358 Check_File_Open (File); 359 360 if feof (File.Stream) /= 0 then 361 return True; 362 363 else 364 Check_Read_Status (File); 365 366 if ungetc (fgetc (File.Stream), File.Stream) = EOF then 367 clearerr (File.Stream); 368 return True; 369 else 370 return False; 371 end if; 372 end if; 373 end End_Of_File; 374 375 ------------------- 376 -- Errno_Message -- 377 ------------------- 378 379 function Errno_Message 380 (Name : String; 381 Errno : Integer := OS_Lib.Errno) return String 382 is 383 begin 384 return Name & ": " & OS_Lib.Errno_Message (Err => 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 end case; 518 519 -- If text_translation_required is true then we need to append either a 520 -- "t" or "b" to the string to get the right mode. 521 522 if text_translation_required then 523 Fopstr (Fptr) := (if Text then 't' else 'b'); 524 Fptr := Fptr + 1; 525 end if; 526 527 Fopstr (Fptr) := ASCII.NUL; 528 end Fopen_Mode; 529 530 ---------- 531 -- Form -- 532 ---------- 533 534 function Form (File : AFCB_Ptr) return String is 535 begin 536 if File = null then 537 raise Status_Error with "Form: file not open"; 538 else 539 return File.Form.all (1 .. File.Form'Length - 1); 540 end if; 541 end Form; 542 543 ------------------ 544 -- Form_Boolean -- 545 ------------------ 546 547 function Form_Boolean 548 (Form : String; 549 Keyword : String; 550 Default : Boolean) return Boolean 551 is 552 V1, V2 : Natural; 553 pragma Unreferenced (V2); 554 555 begin 556 Form_Parameter (Form, Keyword, V1, V2); 557 558 if V1 = 0 then 559 return Default; 560 elsif Form (V1) = 'y' then 561 return True; 562 elsif Form (V1) = 'n' then 563 return False; 564 else 565 raise Use_Error with "invalid Form"; 566 end if; 567 end Form_Boolean; 568 569 ------------------ 570 -- Form_Integer -- 571 ------------------ 572 573 function Form_Integer 574 (Form : String; 575 Keyword : String; 576 Default : Integer) return Integer 577 is 578 V1, V2 : Natural; 579 V : Integer; 580 581 begin 582 Form_Parameter (Form, Keyword, V1, V2); 583 584 if V1 = 0 then 585 return Default; 586 587 else 588 V := 0; 589 590 for J in V1 .. V2 loop 591 if Form (J) not in '0' .. '9' then 592 raise Use_Error with "invalid Form"; 593 else 594 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); 595 end if; 596 597 if V > 999_999 then 598 raise Use_Error with "invalid Form"; 599 end if; 600 end loop; 601 602 return V; 603 end if; 604 end Form_Integer; 605 606 -------------------- 607 -- Form_Parameter -- 608 -------------------- 609 610 procedure Form_Parameter 611 (Form : String; 612 Keyword : String; 613 Start : out Natural; 614 Stop : out Natural) 615 is 616 Klen : constant Integer := Keyword'Length; 617 618 begin 619 for J in Form'First + Klen .. Form'Last - 1 loop 620 if Form (J) = '=' 621 and then Form (J - Klen .. J - 1) = Keyword 622 then 623 Start := J + 1; 624 Stop := Start - 1; 625 while Form (Stop + 1) /= ASCII.NUL 626 and then Form (Stop + 1) /= ',' 627 loop 628 Stop := Stop + 1; 629 end loop; 630 631 return; 632 end if; 633 end loop; 634 635 Start := 0; 636 Stop := 0; 637 end Form_Parameter; 638 639 -------------------------- 640 -- Form_RMS_Context_Key -- 641 -------------------------- 642 643 function Form_RMS_Context_Key 644 (Form : String; 645 VMS_Form : String_Access) return Natural 646 is 647 type Context_Parms is 648 (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode, 649 Force_Stream_Mode, Explicit_Write); 650 -- Ada-fied list of all possible Context keyword values 651 652 Pos : Natural := 0; 653 Klen : Natural := 0; 654 Index : Natural; 655 656 begin 657 -- Find the end of the occupation 658 659 for J in VMS_Form'First .. VMS_Form'Last loop 660 if VMS_Form (J) = ASCII.NUL then 661 Pos := J; 662 exit; 663 end if; 664 end loop; 665 666 Index := Form'First; 667 while Index < Form'Last loop 668 if Form (Index) = '=' then 669 Index := Index + 1; 670 671 -- Loop through the context values and look for a match 672 673 for Parm in Context_Parms loop 674 declare 675 KImage : String := Context_Parms'Image (Parm); 676 677 begin 678 Klen := KImage'Length; 679 To_Lower (KImage); 680 681 if Index + Klen - 1 <= Form'Last 682 and then Form (Index .. Index + Klen - 1) = KImage 683 then 684 case Parm is 685 when Force_Record_Mode => 686 VMS_Form (Pos) := '"'; 687 Pos := Pos + 1; 688 VMS_Form (Pos .. Pos + 6) := "ctx=rec"; 689 Pos := Pos + 7; 690 VMS_Form (Pos) := '"'; 691 Pos := Pos + 1; 692 VMS_Form (Pos) := ','; 693 return Index + Klen; 694 695 when Force_Stream_Mode => 696 VMS_Form (Pos) := '"'; 697 Pos := Pos + 1; 698 VMS_Form (Pos .. Pos + 6) := "ctx=stm"; 699 Pos := Pos + 7; 700 VMS_Form (Pos) := '"'; 701 Pos := Pos + 1; 702 VMS_Form (Pos) := ','; 703 return Index + Klen; 704 705 when others => 706 raise Use_Error 707 with "unimplemented RMS Context Value"; 708 end case; 709 end if; 710 end; 711 end loop; 712 713 raise Use_Error with "unrecognized RMS Context Value"; 714 end if; 715 end loop; 716 717 raise Use_Error with "malformed RMS Context Value"; 718 end Form_RMS_Context_Key; 719 720 ----------------------- 721 -- Form_VMS_RMS_Keys -- 722 ----------------------- 723 724 procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access) 725 is 726 VMS_RMS_Keys_Token : constant String := "vms_rms_keys"; 727 Klen : Natural := VMS_RMS_Keys_Token'Length; 728 Index : Natural; 729 730 -- Ada-fied list of all RMS keywords, translated from the HP C Run-Time 731 -- Library Reference Manual, Table REF-3: RMS Valid Keywords and Values. 732 733 type RMS_Keys is 734 (Access_Callback, Allocation_Quantity, Block_Size, Context, 735 Default_Extension_Quantity, Default_File_Name_String, Error_Callback, 736 File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count, 737 Multiblock_Count, Multibuffer_Count, Maximum_Record_Size, 738 Terminal_Input_Prompt, Record_Attributes, Record_Format, 739 Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options, 740 Timeout_IO_Value); 741 742 begin 743 Index := Form'First + Klen - 1; 744 while Index < Form'Last loop 745 Index := Index + 1; 746 747 -- Scan for the token signalling VMS RMS Keys ahead. Should 748 -- whitespace be eaten??? 749 750 if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then 751 752 -- Allocate the VMS form string that will contain the cryptic 753 -- CRTL RMS strings and initialize it to all nulls. Since the 754 -- CRTL strings are always shorter than the Ada-fied strings, 755 -- it follows that an allocation of the original size will be 756 -- more than adequate. 757 VMS_Form := new String'(Form (Form'First .. Form'Last)); 758 VMS_Form.all := (others => ASCII.NUL); 759 760 if Form (Index) = '=' then 761 Index := Index + 1; 762 if Form (Index) = '(' then 763 while Index < Form'Last loop 764 Index := Index + 1; 765 766 -- Loop through the RMS Keys and dispatch. 767 768 for Key in RMS_Keys loop 769 declare 770 KImage : String := RMS_Keys'Image (Key); 771 772 begin 773 Klen := KImage'Length; 774 To_Lower (KImage); 775 776 if Form (Index .. Index + Klen - 1) = KImage then 777 case Key is 778 when Context => 779 Index := Form_RMS_Context_Key 780 (Form (Index + Klen .. Form'Last), 781 VMS_Form); 782 exit; 783 784 when others => 785 raise Use_Error 786 with "unimplemented VMS RMS Form Key"; 787 end case; 788 end if; 789 end; 790 end loop; 791 792 if Form (Index) = ')' then 793 794 -- Done, erase the unneeded trailing comma and return 795 796 for J in reverse VMS_Form'First .. VMS_Form'Last loop 797 if VMS_Form (J) = ',' then 798 VMS_Form (J) := ASCII.NUL; 799 return; 800 end if; 801 end loop; 802 803 -- Shouldn't be possible to get here 804 805 raise Use_Error; 806 807 elsif Form (Index) = ',' then 808 809 -- Another key ahead, exit inner loop 810 811 null; 812 813 else 814 815 -- Keyword value not terminated correctly 816 817 raise Use_Error with "malformed VMS RMS Form"; 818 end if; 819 end loop; 820 end if; 821 end if; 822 823 -- Found the keyword, but not followed by correct syntax 824 825 raise Use_Error with "malformed VMS RMS Form"; 826 end if; 827 end loop; 828 end Form_VMS_RMS_Keys; 829 830 ------------- 831 -- Is_Open -- 832 ------------- 833 834 function Is_Open (File : AFCB_Ptr) return Boolean is 835 begin 836 -- We return True if the file is open, and the underlying file stream is 837 -- usable. In particular on Windows an application linked with -mwindows 838 -- option set does not have a console attached. In this case standard 839 -- files (Current_Output, Current_Error, Current_Input) are not created. 840 -- We want Is_Open (Current_Output) to return False in this case. 841 842 return File /= null and then fileno (File.Stream) /= -1; 843 end Is_Open; 844 845 ------------------- 846 -- Make_Buffered -- 847 ------------------- 848 849 procedure Make_Buffered 850 (File : AFCB_Ptr; 851 Buf_Siz : Interfaces.C_Streams.size_t) 852 is 853 status : Integer; 854 pragma Unreferenced (status); 855 856 begin 857 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); 858 end Make_Buffered; 859 860 ------------------------ 861 -- Make_Line_Buffered -- 862 ------------------------ 863 864 procedure Make_Line_Buffered 865 (File : AFCB_Ptr; 866 Line_Siz : Interfaces.C_Streams.size_t) 867 is 868 status : Integer; 869 pragma Unreferenced (status); 870 871 begin 872 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); 873 -- No error checking??? 874 end Make_Line_Buffered; 875 876 --------------------- 877 -- Make_Unbuffered -- 878 --------------------- 879 880 procedure Make_Unbuffered (File : AFCB_Ptr) is 881 status : Integer; 882 pragma Unreferenced (status); 883 884 begin 885 status := setvbuf (File.Stream, Null_Address, IONBF, 0); 886 -- No error checking??? 887 end Make_Unbuffered; 888 889 ---------- 890 -- Mode -- 891 ---------- 892 893 function Mode (File : AFCB_Ptr) return File_Mode is 894 begin 895 if File = null then 896 raise Status_Error with "Mode: file not open"; 897 else 898 return File.Mode; 899 end if; 900 end Mode; 901 902 ---------- 903 -- Name -- 904 ---------- 905 906 function Name (File : AFCB_Ptr) return String is 907 begin 908 if File = null then 909 raise Status_Error with "Name: file not open"; 910 else 911 return File.Name.all (1 .. File.Name'Length - 1); 912 end if; 913 end Name; 914 915 ---------- 916 -- Open -- 917 ---------- 918 919 procedure Open 920 (File_Ptr : in out AFCB_Ptr; 921 Dummy_FCB : AFCB'Class; 922 Mode : File_Mode; 923 Name : String; 924 Form : String; 925 Amethod : Character; 926 Creat : Boolean; 927 Text : Boolean; 928 C_Stream : FILEs := NULL_Stream) 929 is 930 pragma Warnings (Off, Dummy_FCB); 931 -- Yes we know this is never assigned a value. That's intended, since 932 -- all we ever use of this value is the tag for dispatching purposes. 933 934 procedure Tmp_Name (Buffer : Address); 935 pragma Import (C, Tmp_Name, "__gnat_tmp_name"); 936 -- Set buffer (a String address) with a temporary filename 937 938 function Get_Case_Sensitive return Integer; 939 pragma Import (C, Get_Case_Sensitive, 940 "__gnat_get_file_names_case_sensitive"); 941 942 File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; 943 -- Set to indicate whether the operating system convention is for file 944 -- names to be case sensitive (e.g., in Unix, set True), or not case 945 -- sensitive (e.g., in Windows, set False). Declared locally to avoid 946 -- breaking the Preelaborate rule that disallows function calls at the 947 -- library level. 948 949 Stream : FILEs := C_Stream; 950 -- Stream which we open in response to this request 951 952 Shared : Shared_Status_Type; 953 -- Setting of Shared_Status field for file 954 955 Fopstr : aliased Fopen_String; 956 -- Mode string used in fopen call 957 958 Formstr : aliased String (1 .. Form'Length + 1); 959 -- Form string with ASCII.NUL appended, folded to lower case 960 961 Is_Text_File : Boolean; 962 963 Tempfile : constant Boolean := (Name'Length = 0); 964 -- Indicates temporary file case 965 966 Namelen : constant Integer := max_path_len; 967 -- Length required for file name, not including final ASCII.NUL. 968 -- Note that we used to reference L_tmpnam here, which is not reliable 969 -- since __gnat_tmp_name does not always use tmpnam. 970 971 Namestr : aliased String (1 .. Namelen + 1); 972 -- Name as given or temporary file name with ASCII.NUL appended 973 974 Fullname : aliased String (1 .. max_path_len + 1); 975 -- Full name (as required for Name function, and as stored in the 976 -- control block in the Name field) with ASCII.NUL appended. 977 978 Full_Name_Len : Integer; 979 -- Length of name actually stored in Fullname 980 981 Encoding : CRTL.Filename_Encoding; 982 -- Filename encoding specified into the form parameter 983 984 begin 985 if File_Ptr /= null then 986 raise Status_Error with "file already open"; 987 end if; 988 989 -- Acquire form string, setting required NUL terminator 990 991 Formstr (1 .. Form'Length) := Form; 992 Formstr (Formstr'Last) := ASCII.NUL; 993 994 -- Convert form string to lower case 995 996 for J in Formstr'Range loop 997 if Formstr (J) in 'A' .. 'Z' then 998 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); 999 end if; 1000 end loop; 1001 1002 -- Acquire setting of shared parameter 1003 1004 declare 1005 V1, V2 : Natural; 1006 1007 begin 1008 Form_Parameter (Formstr, "shared", V1, V2); 1009 1010 if V1 = 0 then 1011 Shared := None; 1012 elsif Formstr (V1 .. V2) = "yes" then 1013 Shared := Yes; 1014 elsif Formstr (V1 .. V2) = "no" then 1015 Shared := No; 1016 else 1017 raise Use_Error with "invalid Form"; 1018 end if; 1019 end; 1020 1021 -- Acquire setting of encoding parameter 1022 1023 declare 1024 V1, V2 : Natural; 1025 1026 begin 1027 Form_Parameter (Formstr, "encoding", V1, V2); 1028 1029 if V1 = 0 then 1030 Encoding := CRTL.Unspecified; 1031 elsif Formstr (V1 .. V2) = "utf8" then 1032 Encoding := CRTL.UTF8; 1033 elsif Formstr (V1 .. V2) = "8bits" then 1034 Encoding := CRTL.ASCII_8bits; 1035 else 1036 raise Use_Error with "invalid Form"; 1037 end if; 1038 end; 1039 1040 -- Acquire setting of text_translation parameter. Only needed if this is 1041 -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but 1042 -- if the Form says Text_Translation=No, we use binary mode, so new-line 1043 -- will be just LF, even on Windows. 1044 1045 Is_Text_File := Text; 1046 1047 if Is_Text_File then 1048 Is_Text_File := 1049 Form_Boolean (Formstr, "text_translation", Default => True); 1050 end if; 1051 1052 -- Acquire settings of target specific form parameters on VMS. Only 1053 -- Context is currently implemented, for forcing a byte stream mode 1054 -- read. On non-VMS systems, the settings are ultimately ignored in 1055 -- the implementation of __gnat_fopen. 1056 1057 -- Should a warning be issued on non-VMS systems? That's not possible 1058 -- without testing System.OpenVMS boolean which isn't present in most 1059 -- non-VMS versions of package System. 1060 1061 Form_VMS_RMS_Keys (Formstr, VMS_Formstr); 1062 1063 -- If we were given a stream (call from xxx.C_Streams.Open), then set 1064 -- the full name to the given one, and skip to end of processing. 1065 1066 if Stream /= NULL_Stream then 1067 Full_Name_Len := Name'Length + 1; 1068 Fullname (1 .. Full_Name_Len - 1) := Name; 1069 Fullname (Full_Name_Len) := ASCII.NUL; 1070 1071 -- Normal case of Open or Create 1072 1073 else 1074 -- If temporary file case, get temporary file name and add to the 1075 -- list of temporary files to be deleted on exit. 1076 1077 if Tempfile then 1078 if not Creat then 1079 raise Name_Error with "opening temp file without creating it"; 1080 end if; 1081 1082 Tmp_Name (Namestr'Address); 1083 1084 if Namestr (1) = ASCII.NUL then 1085 raise Use_Error with "invalid temp file name"; 1086 end if; 1087 1088 -- Chain to temp file list, ensuring thread safety with a lock 1089 1090 begin 1091 SSL.Lock_Task.all; 1092 Temp_Files := 1093 new Temp_File_Record'(Name => Namestr, Next => Temp_Files); 1094 SSL.Unlock_Task.all; 1095 1096 exception 1097 when others => 1098 SSL.Unlock_Task.all; 1099 raise; 1100 end; 1101 1102 -- Normal case of non-null name given 1103 1104 else 1105 if Name'Length > Namelen then 1106 raise Name_Error with "file name too long"; 1107 end if; 1108 1109 Namestr (1 .. Name'Length) := Name; 1110 Namestr (Name'Length + 1) := ASCII.NUL; 1111 end if; 1112 1113 -- Get full name in accordance with the advice of RM A.8.2(22) 1114 1115 full_name (Namestr'Address, Fullname'Address); 1116 1117 if Fullname (1) = ASCII.NUL then 1118 raise Use_Error with Errno_Message (Name); 1119 end if; 1120 1121 Full_Name_Len := 1; 1122 while Full_Name_Len < Fullname'Last 1123 and then Fullname (Full_Name_Len) /= ASCII.NUL 1124 loop 1125 Full_Name_Len := Full_Name_Len + 1; 1126 end loop; 1127 1128 -- Fullname is generated by calling system's full_name. The problem 1129 -- is, full_name does nothing about the casing, so a file name 1130 -- comparison may generally speaking not be valid on non-case- 1131 -- sensitive systems, and in particular we get unexpected failures 1132 -- on Windows/Vista because of this. So we use s-casuti to force 1133 -- the name to lower case. 1134 1135 if not File_Names_Case_Sensitive then 1136 To_Lower (Fullname (1 .. Full_Name_Len)); 1137 end if; 1138 1139 -- If Shared=None or Shared=Yes, then check for the existence of 1140 -- another file with exactly the same full name. 1141 1142 if Shared /= No then 1143 declare 1144 P : AFCB_Ptr; 1145 1146 begin 1147 -- Take a task lock to protect Open_Files 1148 1149 SSL.Lock_Task.all; 1150 1151 -- Search list of open files 1152 1153 P := Open_Files; 1154 while P /= null loop 1155 if Fullname (1 .. Full_Name_Len) = P.Name.all then 1156 1157 -- If we get a match, and either file has Shared=None, 1158 -- then raise Use_Error, since we don't allow two files 1159 -- of the same name to be opened unless they specify the 1160 -- required sharing mode. 1161 1162 if Shared = None 1163 or else P.Shared_Status = None 1164 then 1165 raise Use_Error with "reopening shared file"; 1166 1167 -- If both files have Shared=Yes, then we acquire the 1168 -- stream from the located file to use as our stream. 1169 1170 elsif Shared = Yes 1171 and then P.Shared_Status = Yes 1172 then 1173 Stream := P.Stream; 1174 exit; 1175 1176 -- Otherwise one of the files has Shared=Yes and one has 1177 -- Shared=No. If the current file has Shared=No then all 1178 -- is well but we don't want to share any other file's 1179 -- stream. If the current file has Shared=Yes, we would 1180 -- like to share a stream, but not from a file that has 1181 -- Shared=No, so either way, we just continue the search. 1182 1183 else 1184 null; 1185 end if; 1186 end if; 1187 1188 P := P.Next; 1189 end loop; 1190 1191 SSL.Unlock_Task.all; 1192 1193 exception 1194 when others => 1195 SSL.Unlock_Task.all; 1196 raise; 1197 end; 1198 end if; 1199 1200 -- Open specified file if we did not find an existing stream 1201 1202 if Stream = NULL_Stream then 1203 Fopen_Mode (Mode, Is_Text_File, Creat, Amethod, Fopstr); 1204 1205 -- A special case, if we are opening (OPEN case) a file and the 1206 -- mode returned by Fopen_Mode is not "r" or "r+", then we first 1207 -- make sure that the file exists as required by Ada semantics. 1208 1209 if not Creat and then Fopstr (1) /= 'r' then 1210 if file_exists (Namestr'Address) = 0 then 1211 raise Name_Error with Errno_Message (Name); 1212 end if; 1213 end if; 1214 1215 -- Now open the file. Note that we use the name as given in the 1216 -- original Open call for this purpose, since that seems the 1217 -- clearest implementation of the intent. It would presumably 1218 -- work to use the full name here, but if there is any difference, 1219 -- then we should use the name used in the call. 1220 1221 -- Note: for a corresponding delete, we will use the full name, 1222 -- since by the time of the delete, the current working directory 1223 -- may have changed and we do not want to delete a different file. 1224 1225 if VMS_Formstr = null then 1226 Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, 1227 Null_Address); 1228 else 1229 Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, 1230 VMS_Formstr.all'Address); 1231 end if; 1232 1233 -- No need to keep this around 1234 1235 if VMS_Formstr /= null then 1236 Free (VMS_Formstr); 1237 end if; 1238 1239 if Stream = NULL_Stream then 1240 1241 -- Raise Name_Error if trying to open a non-existent file. 1242 -- Otherwise raise Use_Error. 1243 1244 -- Should we raise Device_Error for ENOSPC??? 1245 1246 declare 1247 function Is_File_Not_Found_Error 1248 (Errno_Value : Integer) return Integer; 1249 pragma Import 1250 (C, Is_File_Not_Found_Error, 1251 "__gnat_is_file_not_found_error"); 1252 -- Non-zero when the given errno value indicates a non- 1253 -- existing file. 1254 1255 Errno : constant Integer := OS_Lib.Errno; 1256 Message : constant String := Errno_Message (Name, Errno); 1257 1258 begin 1259 if Is_File_Not_Found_Error (Errno) /= 0 then 1260 raise Name_Error with Message; 1261 else 1262 raise Use_Error with Message; 1263 end if; 1264 end; 1265 end if; 1266 end if; 1267 end if; 1268 1269 -- Stream has been successfully located or opened, so now we are 1270 -- committed to completing the opening of the file. Allocate block on 1271 -- heap and fill in its fields. 1272 1273 File_Ptr := AFCB_Allocate (Dummy_FCB); 1274 1275 File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0); 1276 File_Ptr.Is_System_File := False; 1277 File_Ptr.Is_Text_File := Is_Text_File; 1278 File_Ptr.Shared_Status := Shared; 1279 File_Ptr.Access_Method := Amethod; 1280 File_Ptr.Stream := Stream; 1281 File_Ptr.Form := new String'(Formstr); 1282 File_Ptr.Name := new String'(Fullname (1 .. Full_Name_Len)); 1283 File_Ptr.Mode := Mode; 1284 File_Ptr.Is_Temporary_File := Tempfile; 1285 File_Ptr.Encoding := Encoding; 1286 1287 Chain_File (File_Ptr); 1288 Append_Set (File_Ptr); 1289 end Open; 1290 1291 ------------------------ 1292 -- Raise_Device_Error -- 1293 ------------------------ 1294 1295 procedure Raise_Device_Error 1296 (File : AFCB_Ptr; 1297 Errno : Integer := OS_Lib.Errno) 1298 is 1299 begin 1300 -- Clear error status so that the same error is not reported twice 1301 1302 if File /= null then 1303 clearerr (File.Stream); 1304 end if; 1305 1306 raise Device_Error with OS_Lib.Errno_Message (Err => Errno); 1307 end Raise_Device_Error; 1308 1309 -------------- 1310 -- Read_Buf -- 1311 -------------- 1312 1313 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is 1314 Nread : size_t; 1315 1316 begin 1317 Nread := fread (Buf, 1, Siz, File.Stream); 1318 1319 if Nread = Siz then 1320 return; 1321 1322 elsif ferror (File.Stream) /= 0 then 1323 Raise_Device_Error (File); 1324 1325 elsif Nread = 0 then 1326 raise End_Error; 1327 1328 else -- 0 < Nread < Siz 1329 raise Data_Error with "not enough data read"; 1330 end if; 1331 end Read_Buf; 1332 1333 procedure Read_Buf 1334 (File : AFCB_Ptr; 1335 Buf : Address; 1336 Siz : Interfaces.C_Streams.size_t; 1337 Count : out Interfaces.C_Streams.size_t) 1338 is 1339 begin 1340 Count := fread (Buf, 1, Siz, File.Stream); 1341 1342 if Count = 0 and then ferror (File.Stream) /= 0 then 1343 Raise_Device_Error (File); 1344 end if; 1345 end Read_Buf; 1346 1347 ----------- 1348 -- Reset -- 1349 ----------- 1350 1351 -- The reset which does not change the mode simply does a rewind 1352 1353 procedure Reset (File_Ptr : access AFCB_Ptr) is 1354 File : AFCB_Ptr renames File_Ptr.all; 1355 begin 1356 Check_File_Open (File); 1357 Reset (File_Ptr, File.Mode); 1358 end Reset; 1359 1360 -- The reset with a change in mode is done using freopen, and is not 1361 -- permitted except for regular files (since otherwise there is no name for 1362 -- the freopen, and in any case it seems meaningless). 1363 1364 procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is 1365 File : AFCB_Ptr renames File_Ptr.all; 1366 Fopstr : aliased Fopen_String; 1367 1368 begin 1369 Check_File_Open (File); 1370 1371 -- Change of mode not allowed for shared file or file with no name or 1372 -- file that is not a regular file, or for a system file. Note that we 1373 -- allow the "change" of mode if it is not in fact doing a change. 1374 1375 if Mode /= File.Mode then 1376 if File.Shared_Status = Yes then 1377 raise Use_Error with "cannot change mode of shared file"; 1378 elsif File.Name'Length <= 1 then 1379 raise Use_Error with "cannot change mode of temp file"; 1380 elsif File.Is_System_File then 1381 raise Use_Error with "cannot change mode of system file"; 1382 elsif not File.Is_Regular_File then 1383 raise Use_Error with "cannot change mode of non-regular file"; 1384 end if; 1385 end if; 1386 1387 -- For In_File or Inout_File for a regular file, we can just do a rewind 1388 -- if the mode is unchanged, which is more efficient than doing a full 1389 -- reopen. 1390 1391 if Mode = File.Mode 1392 and then Mode in Read_File_Mode 1393 then 1394 rewind (File.Stream); 1395 1396 -- Here the change of mode is permitted, we do it by reopening the file 1397 -- in the new mode and replacing the stream with a new stream. 1398 1399 else 1400 Fopen_Mode 1401 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr); 1402 1403 Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr); 1404 1405 if VMS_Formstr = null then 1406 File.Stream := freopen 1407 (File.Name.all'Address, Fopstr'Address, File.Stream, 1408 File.Encoding, Null_Address); 1409 else 1410 File.Stream := freopen 1411 (File.Name.all'Address, Fopstr'Address, File.Stream, 1412 File.Encoding, VMS_Formstr.all'Address); 1413 end if; 1414 1415 if VMS_Formstr /= null then 1416 Free (VMS_Formstr); 1417 end if; 1418 1419 if File.Stream = NULL_Stream then 1420 Close (File_Ptr); 1421 raise Use_Error; 1422 else 1423 File.Mode := Mode; 1424 Append_Set (File); 1425 end if; 1426 end if; 1427 end Reset; 1428 1429 --------------- 1430 -- Write_Buf -- 1431 --------------- 1432 1433 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is 1434 begin 1435 -- Note: for most purposes, the Siz and 1 parameters in the fwrite call 1436 -- could be reversed, but on VMS, this is a better choice, since for 1437 -- some file formats, reversing the parameters results in records of one 1438 -- byte each. 1439 1440 SSL.Abort_Defer.all; 1441 1442 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then 1443 if Siz /= 0 then 1444 SSL.Abort_Undefer.all; 1445 Raise_Device_Error (File); 1446 end if; 1447 end if; 1448 1449 SSL.Abort_Undefer.all; 1450 end Write_Buf; 1451 1452end System.File_IO; 1453