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-2003 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 2, 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. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- As a special exception, if other files instantiate generics from this -- 23-- unit, or you link this unit with other files to produce an executable, -- 24-- this unit does not by itself cause the resulting executable to be -- 25-- covered by the GNU General Public License. This exception does not -- 26-- however invalidate any other reasons why the executable file might be -- 27-- covered by the GNU Public License. -- 28-- -- 29-- GNAT was originally developed by the GNAT team at New York University. -- 30-- Extensive contributions were provided by Ada Core Technologies Inc. -- 31-- -- 32------------------------------------------------------------------------------ 33 34with Ada.Finalization; use Ada.Finalization; 35with Ada.IO_Exceptions; use Ada.IO_Exceptions; 36with Interfaces.C_Streams; use Interfaces.C_Streams; 37with System.CRTL; 38with System.Soft_Links; 39with Unchecked_Deallocation; 40 41package body System.File_IO is 42 43 use System.File_Control_Block; 44 45 package SSL renames System.Soft_Links; 46 47 use type System.CRTL.size_t; 48 49 ---------------------- 50 -- Global Variables -- 51 ---------------------- 52 53 Open_Files : AFCB_Ptr; 54 -- This points to a list of AFCB's for all open files. This is a doubly 55 -- linked list, with the Prev pointer of the first entry, and the Next 56 -- pointer of the last entry containing null. Note that this global 57 -- variable must be properly protected to provide thread safety. 58 59 type Temp_File_Record; 60 type Temp_File_Record_Ptr is access all Temp_File_Record; 61 62 type Temp_File_Record is record 63 Name : String (1 .. L_tmpnam + 1); 64 Next : Temp_File_Record_Ptr; 65 end record; 66 -- One of these is allocated for each temporary file created 67 68 Temp_Files : Temp_File_Record_Ptr; 69 -- Points to list of names of temporary files. Note that this global 70 -- variable must be properly protected to provide thread safety. 71 72 type File_IO_Clean_Up_Type is new Controlled with null record; 73 -- The closing of all open files and deletion of temporary files is an 74 -- action which takes place at the end of execution of the main program. 75 -- This action can be implemented using a library level object which 76 -- gets finalized at the end of the main program execution. The above is 77 -- a controlled type introduced for this purpose. 78 79 procedure Finalize (V : in out File_IO_Clean_Up_Type); 80 -- This is the finalize operation that is used to do the cleanup. 81 82 File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; 83 pragma Warnings (Off, File_IO_Clean_Up_Object); 84 -- This is the single object of the type that triggers the finalization 85 -- call. Since it is at the library level, this happens just before the 86 -- environment task is finalized. 87 88 text_translation_required : Boolean; 89 pragma Import 90 (C, text_translation_required, "__gnat_text_translation_required"); 91 -- If true, add appropriate suffix to control string for Open. 92 93 ----------------------- 94 -- Local Subprograms -- 95 ----------------------- 96 97 procedure Free_String is new Unchecked_Deallocation (String, Pstring); 98 99 subtype Fopen_String is String (1 .. 4); 100 -- Holds open string (longest is "w+b" & nul) 101 102 procedure Fopen_Mode 103 (Mode : File_Mode; 104 Text : Boolean; 105 Creat : Boolean; 106 Amethod : Character; 107 Fopstr : out Fopen_String); 108 -- Determines proper open mode for a file to be opened in the given 109 -- Ada mode. Text is true for a text file and false otherwise, and 110 -- Creat is true for a create call, and False for an open call. The 111 -- value stored in Fopstr is a nul-terminated string suitable for a 112 -- call to fopen or freopen. Amethod is the character designating 113 -- the access method from the Access_Method field of the FCB. 114 115 ---------------- 116 -- Append_Set -- 117 ---------------- 118 119 procedure Append_Set (File : AFCB_Ptr) is 120 begin 121 if File.Mode = Append_File then 122 if fseek (File.Stream, 0, SEEK_END) /= 0 then 123 raise Device_Error; 124 end if; 125 end if; 126 end Append_Set; 127 128 ---------------- 129 -- Chain_File -- 130 ---------------- 131 132 procedure Chain_File (File : AFCB_Ptr) is 133 begin 134 -- Take a task lock, to protect the global data value Open_Files 135 136 SSL.Lock_Task.all; 137 138 -- Do the chaining operation locked 139 140 File.Next := Open_Files; 141 File.Prev := null; 142 Open_Files := File; 143 144 if File.Next /= null then 145 File.Next.Prev := File; 146 end if; 147 148 SSL.Unlock_Task.all; 149 150 exception 151 when others => 152 SSL.Unlock_Task.all; 153 raise; 154 end Chain_File; 155 156 --------------------- 157 -- Check_File_Open -- 158 --------------------- 159 160 procedure Check_File_Open (File : AFCB_Ptr) is 161 begin 162 if File = null then 163 raise Status_Error; 164 end if; 165 end Check_File_Open; 166 167 ----------------------- 168 -- Check_Read_Status -- 169 ----------------------- 170 171 procedure Check_Read_Status (File : AFCB_Ptr) is 172 begin 173 if File = null then 174 raise Status_Error; 175 elsif File.Mode > Inout_File then 176 raise Mode_Error; 177 end if; 178 end Check_Read_Status; 179 180 ------------------------ 181 -- Check_Write_Status -- 182 ------------------------ 183 184 procedure Check_Write_Status (File : AFCB_Ptr) is 185 begin 186 if File = null then 187 raise Status_Error; 188 elsif File.Mode = In_File then 189 raise Mode_Error; 190 end if; 191 end Check_Write_Status; 192 193 ----------- 194 -- Close -- 195 ----------- 196 197 procedure Close (File : in out AFCB_Ptr) is 198 Close_Status : int := 0; 199 Dup_Strm : Boolean := False; 200 201 begin 202 Check_File_Open (File); 203 AFCB_Close (File); 204 205 -- Take a task lock, to protect the global data value Open_Files 206 207 SSL.Lock_Task.all; 208 209 -- Sever the association between the given file and its associated 210 -- external file. The given file is left closed. Do not perform system 211 -- closes on the standard input, output and error files and also do 212 -- not attempt to close a stream that does not exist (signalled by a 213 -- null stream value -- happens in some error situations). 214 215 if not File.Is_System_File 216 and then File.Stream /= NULL_Stream 217 then 218 -- Do not do an fclose if this is a shared file and there is 219 -- at least one other instance of the stream that is open. 220 221 if File.Shared_Status = Yes then 222 declare 223 P : AFCB_Ptr; 224 225 begin 226 P := Open_Files; 227 while P /= null loop 228 if P /= File 229 and then File.Stream = P.Stream 230 then 231 Dup_Strm := True; 232 exit; 233 end if; 234 235 P := P.Next; 236 end loop; 237 end; 238 end if; 239 240 -- Do the fclose unless this was a duplicate in the shared case 241 242 if not Dup_Strm then 243 Close_Status := fclose (File.Stream); 244 end if; 245 end if; 246 247 -- Dechain file from list of open files and then free the storage 248 249 if File.Prev = null then 250 Open_Files := File.Next; 251 else 252 File.Prev.Next := File.Next; 253 end if; 254 255 if File.Next /= null then 256 File.Next.Prev := File.Prev; 257 end if; 258 259 -- Deallocate some parts of the file structure that were kept in heap 260 -- storage with the exception of system files (standard input, output 261 -- and error) since they had some information allocated in the stack. 262 263 if not File.Is_System_File then 264 Free_String (File.Name); 265 Free_String (File.Form); 266 AFCB_Free (File); 267 end if; 268 269 File := null; 270 271 if Close_Status /= 0 then 272 raise Device_Error; 273 end if; 274 275 SSL.Unlock_Task.all; 276 277 exception 278 when others => 279 SSL.Unlock_Task.all; 280 raise; 281 end Close; 282 283 ------------ 284 -- Delete -- 285 ------------ 286 287 procedure Delete (File : in out AFCB_Ptr) is 288 begin 289 Check_File_Open (File); 290 291 if not File.Is_Regular_File then 292 raise Use_Error; 293 end if; 294 295 declare 296 Filename : aliased constant String := File.Name.all; 297 298 begin 299 Close (File); 300 301 -- Now unlink the external file. Note that we use the full name 302 -- in this unlink, because the working directory may have changed 303 -- since we did the open, and we want to unlink the right file! 304 305 if unlink (Filename'Address) = -1 then 306 raise Use_Error; 307 end if; 308 end; 309 end Delete; 310 311 ----------------- 312 -- End_Of_File -- 313 ----------------- 314 315 function End_Of_File (File : AFCB_Ptr) return Boolean is 316 begin 317 Check_File_Open (File); 318 319 if feof (File.Stream) /= 0 then 320 return True; 321 322 else 323 Check_Read_Status (File); 324 325 if ungetc (fgetc (File.Stream), File.Stream) = EOF then 326 clearerr (File.Stream); 327 return True; 328 else 329 return False; 330 end if; 331 end if; 332 end End_Of_File; 333 334 -------------- 335 -- Finalize -- 336 -------------- 337 338 -- Note: we do not need to worry about locking against multiple task 339 -- access in this routine, since it is called only from the environment 340 -- task just before terminating execution. 341 342 procedure Finalize (V : in out File_IO_Clean_Up_Type) is 343 pragma Warnings (Off, V); 344 345 Fptr1 : AFCB_Ptr; 346 Fptr2 : AFCB_Ptr; 347 348 Discard : int; 349 pragma Unreferenced (Discard); 350 351 begin 352 -- Take a lock to protect global Open_Files data structure 353 354 SSL.Lock_Task.all; 355 356 -- First close all open files (the slightly complex form of this loop 357 -- is required because Close as a side effect nulls out its argument) 358 359 Fptr1 := Open_Files; 360 while Fptr1 /= null loop 361 Fptr2 := Fptr1.Next; 362 Close (Fptr1); 363 Fptr1 := Fptr2; 364 end loop; 365 366 -- Now unlink all temporary files. We do not bother to free the 367 -- blocks because we are just about to terminate the program. We 368 -- also ignore any errors while attempting these unlink operations. 369 370 while Temp_Files /= null loop 371 Discard := unlink (Temp_Files.Name'Address); 372 Temp_Files := Temp_Files.Next; 373 end loop; 374 375 SSL.Unlock_Task.all; 376 377 exception 378 when others => 379 SSL.Unlock_Task.all; 380 raise; 381 end Finalize; 382 383 ----------- 384 -- Flush -- 385 ----------- 386 387 procedure Flush (File : AFCB_Ptr) is 388 begin 389 Check_Write_Status (File); 390 391 if fflush (File.Stream) = 0 then 392 return; 393 else 394 raise Device_Error; 395 end if; 396 end Flush; 397 398 ---------------- 399 -- Fopen_Mode -- 400 ---------------- 401 402 -- The fopen mode to be used is shown by the following table: 403 404 -- OPEN CREATE 405 -- Append_File "r+" "w+" 406 -- In_File "r" "w+" 407 -- Out_File (Direct_IO) "r+" "w" 408 -- Out_File (all others) "w" "w" 409 -- Inout_File "r+" "w+" 410 411 -- Note: we do not use "a" or "a+" for Append_File, since this would not 412 -- work in the case of stream files, where even if in append file mode, 413 -- you can reset to earlier points in the file. The caller must use the 414 -- Append_Set routine to deal with the necessary positioning. 415 416 -- Note: in several cases, the fopen mode used allows reading and 417 -- writing, but the setting of the Ada mode is more restrictive. For 418 -- instance, Create in In_File mode uses "w+" which allows writing, 419 -- but the Ada mode In_File will cause any write operations to be 420 -- rejected with Mode_Error in any case. 421 422 -- Note: for the Out_File/Open cases for other than the Direct_IO case, 423 -- an initial call will be made by the caller to first open the file in 424 -- "r" mode to be sure that it exists. The real open, in "w" mode, will 425 -- then destroy this file. This is peculiar, but that's what Ada semantics 426 -- require and the ACVT tests insist on! 427 428 -- If text file translation is required, then either b or t is 429 -- added to the mode, depending on the setting of Text. 430 431 procedure Fopen_Mode 432 (Mode : File_Mode; 433 Text : Boolean; 434 Creat : Boolean; 435 Amethod : Character; 436 Fopstr : out Fopen_String) 437 is 438 Fptr : Positive; 439 440 begin 441 case Mode is 442 when In_File => 443 if Creat then 444 Fopstr (1) := 'w'; 445 Fopstr (2) := '+'; 446 Fptr := 3; 447 else 448 Fopstr (1) := 'r'; 449 Fptr := 2; 450 end if; 451 452 when Out_File => 453 if Amethod = 'D' and not Creat then 454 Fopstr (1) := 'r'; 455 Fopstr (2) := '+'; 456 Fptr := 3; 457 else 458 Fopstr (1) := 'w'; 459 Fptr := 2; 460 end if; 461 462 when Inout_File | Append_File => 463 if Creat then 464 Fopstr (1) := 'w'; 465 else 466 Fopstr (1) := 'r'; 467 end if; 468 469 Fopstr (2) := '+'; 470 Fptr := 3; 471 472 end case; 473 474 -- If text_translation_required is true then we need to append 475 -- either a t or b to the string to get the right mode 476 477 if text_translation_required then 478 if Text then 479 Fopstr (Fptr) := 't'; 480 else 481 Fopstr (Fptr) := 'b'; 482 end if; 483 484 Fptr := Fptr + 1; 485 end if; 486 487 Fopstr (Fptr) := ASCII.NUL; 488 end Fopen_Mode; 489 490 ---------- 491 -- Form -- 492 ---------- 493 494 function Form (File : in AFCB_Ptr) return String is 495 begin 496 if File = null then 497 raise Status_Error; 498 else 499 return File.Form.all (1 .. File.Form'Length - 1); 500 end if; 501 end Form; 502 503 ------------------ 504 -- Form_Boolean -- 505 ------------------ 506 507 function Form_Boolean 508 (Form : String; 509 Keyword : String; 510 Default : Boolean) 511 return Boolean 512 is 513 V1, V2 : Natural; 514 515 begin 516 Form_Parameter (Form, Keyword, V1, V2); 517 518 if V1 = 0 then 519 return Default; 520 521 elsif Form (V1) = 'y' then 522 return True; 523 524 elsif Form (V1) = 'n' then 525 return False; 526 527 else 528 raise Use_Error; 529 end if; 530 end Form_Boolean; 531 532 ------------------ 533 -- Form_Integer -- 534 ------------------ 535 536 function Form_Integer 537 (Form : String; 538 Keyword : String; 539 Default : Integer) 540 return Integer 541 is 542 V1, V2 : Natural; 543 V : Integer; 544 545 begin 546 Form_Parameter (Form, Keyword, V1, V2); 547 548 if V1 = 0 then 549 return Default; 550 551 else 552 V := 0; 553 554 for J in V1 .. V2 loop 555 if Form (J) not in '0' .. '9' then 556 raise Use_Error; 557 else 558 V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); 559 end if; 560 561 if V > 999_999 then 562 raise Use_Error; 563 end if; 564 end loop; 565 566 return V; 567 end if; 568 end Form_Integer; 569 570 -------------------- 571 -- Form_Parameter -- 572 -------------------- 573 574 procedure Form_Parameter 575 (Form : String; 576 Keyword : String; 577 Start : out Natural; 578 Stop : out Natural) 579 is 580 Klen : constant Integer := Keyword'Length; 581 582 -- Start of processing for Form_Parameter 583 584 begin 585 for J in Form'First + Klen .. Form'Last - 1 loop 586 if Form (J) = '=' 587 and then Form (J - Klen .. J - 1) = Keyword 588 then 589 Start := J + 1; 590 Stop := Start - 1; 591 592 while Form (Stop + 1) /= ASCII.NUL 593 and then Form (Stop + 1) /= ',' 594 loop 595 Stop := Stop + 1; 596 end loop; 597 598 return; 599 end if; 600 end loop; 601 602 Start := 0; 603 Stop := 0; 604 end Form_Parameter; 605 606 ------------- 607 -- Is_Open -- 608 ------------- 609 610 function Is_Open (File : in AFCB_Ptr) return Boolean is 611 begin 612 return (File /= null); 613 end Is_Open; 614 615 ------------------- 616 -- Make_Buffered -- 617 ------------------- 618 619 procedure Make_Buffered 620 (File : AFCB_Ptr; 621 Buf_Siz : Interfaces.C_Streams.size_t) 622 is 623 status : Integer; 624 pragma Unreferenced (status); 625 626 begin 627 status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); 628 end Make_Buffered; 629 630 ------------------------ 631 -- Make_Line_Buffered -- 632 ------------------------ 633 634 procedure Make_Line_Buffered 635 (File : AFCB_Ptr; 636 Line_Siz : Interfaces.C_Streams.size_t) 637 is 638 status : Integer; 639 pragma Unreferenced (status); 640 641 begin 642 status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); 643 end Make_Line_Buffered; 644 645 --------------------- 646 -- Make_Unbuffered -- 647 --------------------- 648 649 procedure Make_Unbuffered (File : AFCB_Ptr) is 650 status : Integer; 651 pragma Unreferenced (status); 652 653 begin 654 status := setvbuf (File.Stream, Null_Address, IONBF, 0); 655 end Make_Unbuffered; 656 657 ---------- 658 -- Mode -- 659 ---------- 660 661 function Mode (File : in AFCB_Ptr) return File_Mode is 662 begin 663 if File = null then 664 raise Status_Error; 665 else 666 return File.Mode; 667 end if; 668 end Mode; 669 670 ---------- 671 -- Name -- 672 ---------- 673 674 function Name (File : in AFCB_Ptr) return String is 675 begin 676 if File = null then 677 raise Status_Error; 678 else 679 return File.Name.all (1 .. File.Name'Length - 1); 680 end if; 681 end Name; 682 683 ---------- 684 -- Open -- 685 ---------- 686 687 procedure Open 688 (File_Ptr : in out AFCB_Ptr; 689 Dummy_FCB : in AFCB'Class; 690 Mode : File_Mode; 691 Name : String; 692 Form : String; 693 Amethod : Character; 694 Creat : Boolean; 695 Text : Boolean; 696 C_Stream : FILEs := NULL_Stream) 697 is 698 pragma Warnings (Off, Dummy_FCB); 699 -- Yes we know this is never assigned a value. That's intended, since 700 -- all we ever use of this value is the tag for dispatching purposes. 701 702 procedure Tmp_Name (Buffer : Address); 703 pragma Import (C, Tmp_Name, "__gnat_tmp_name"); 704 -- set buffer (a String address) with a temporary filename. 705 706 Stream : FILEs := C_Stream; 707 -- Stream which we open in response to this request 708 709 Shared : Shared_Status_Type; 710 -- Setting of Shared_Status field for file 711 712 Fopstr : aliased Fopen_String; 713 -- Mode string used in fopen call 714 715 Formstr : aliased String (1 .. Form'Length + 1); 716 -- Form string with ASCII.NUL appended, folded to lower case 717 718 Tempfile : constant Boolean := (Name'Length = 0); 719 -- Indicates temporary file case 720 721 Namelen : constant Integer := max_path_len; 722 -- Length required for file name, not including final ASCII.NUL 723 -- Note that we used to reference L_tmpnam here, which is not 724 -- reliable since __gnat_tmp_name does not always use tmpnam. 725 726 Namestr : aliased String (1 .. Namelen + 1); 727 -- Name as given or temporary file name with ASCII.NUL appended 728 729 Fullname : aliased String (1 .. max_path_len + 1); 730 -- Full name (as required for Name function, and as stored in the 731 -- control block in the Name field) with ASCII.NUL appended. 732 733 Full_Name_Len : Integer; 734 -- Length of name actually stored in Fullname 735 736 begin 737 if File_Ptr /= null then 738 raise Status_Error; 739 end if; 740 741 -- Acquire form string, setting required NUL terminator 742 743 Formstr (1 .. Form'Length) := Form; 744 Formstr (Formstr'Last) := ASCII.NUL; 745 746 -- Convert form string to lower case 747 748 for J in Formstr'Range loop 749 if Formstr (J) in 'A' .. 'Z' then 750 Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); 751 end if; 752 end loop; 753 754 -- Acquire setting of shared parameter 755 756 declare 757 V1, V2 : Natural; 758 759 begin 760 Form_Parameter (Formstr, "shared", V1, V2); 761 762 if V1 = 0 then 763 Shared := None; 764 765 elsif Formstr (V1 .. V2) = "yes" then 766 Shared := Yes; 767 768 elsif Formstr (V1 .. V2) = "no" then 769 Shared := No; 770 771 else 772 raise Use_Error; 773 end if; 774 end; 775 776 -- If we were given a stream (call from xxx.C_Streams.Open), then set 777 -- full name to null and that is all we have to do in this case so 778 -- skip to end of processing. 779 780 if Stream /= NULL_Stream then 781 Fullname (1) := ASCII.Nul; 782 Full_Name_Len := 1; 783 784 -- Normal case of Open or Create 785 786 else 787 -- If temporary file case, get temporary file name and add 788 -- to the list of temporary files to be deleted on exit. 789 790 if Tempfile then 791 if not Creat then 792 raise Name_Error; 793 end if; 794 795 Tmp_Name (Namestr'Address); 796 797 if Namestr (1) = ASCII.NUL then 798 raise Use_Error; 799 end if; 800 801 -- Chain to temp file list, ensuring thread safety with a lock 802 803 begin 804 SSL.Lock_Task.all; 805 Temp_Files := 806 new Temp_File_Record'(Name => Namestr, Next => Temp_Files); 807 SSL.Unlock_Task.all; 808 809 exception 810 when others => 811 SSL.Unlock_Task.all; 812 raise; 813 end; 814 815 -- Normal case of non-null name given 816 817 else 818 if Name'Length > Namelen then 819 raise Name_Error; 820 end if; 821 822 Namestr (1 .. Name'Length) := Name; 823 Namestr (Name'Length + 1) := ASCII.NUL; 824 end if; 825 826 -- Get full name in accordance with the advice of RM A.8.2(22). 827 828 full_name (Namestr'Address, Fullname'Address); 829 830 if Fullname (1) = ASCII.NUL then 831 raise Use_Error; 832 end if; 833 834 Full_Name_Len := 1; 835 while Full_Name_Len < Fullname'Last 836 and then Fullname (Full_Name_Len) /= ASCII.NUL 837 loop 838 Full_Name_Len := Full_Name_Len + 1; 839 end loop; 840 841 -- If Shared=None or Shared=Yes, then check for the existence 842 -- of another file with exactly the same full name. 843 844 if Shared /= No then 845 declare 846 P : AFCB_Ptr; 847 848 begin 849 -- Take a task lock to protect Open_Files 850 851 SSL.Lock_Task.all; 852 853 -- Search list of open files 854 855 P := Open_Files; 856 while P /= null loop 857 if Fullname (1 .. Full_Name_Len) = P.Name.all then 858 859 -- If we get a match, and either file has Shared=None, 860 -- then raise Use_Error, since we don't allow two 861 -- files of the same name to be opened unless they 862 -- specify the required sharing mode. 863 864 if Shared = None 865 or else P.Shared_Status = None 866 then 867 raise Use_Error; 868 869 -- If both files have Shared=Yes, then we acquire the 870 -- stream from the located file to use as our stream. 871 872 elsif Shared = Yes 873 and then P.Shared_Status = Yes 874 then 875 Stream := P.Stream; 876 exit; 877 878 -- Otherwise one of the files has Shared=Yes and one 879 -- has Shared=No. If the current file has Shared=No 880 -- then all is well but we don't want to share any 881 -- other file's stream. If the current file has 882 -- Shared=Yes, we would like to share a stream, but 883 -- not from a file that has Shared=No, so in either 884 -- case we just keep going on the search. 885 886 else 887 null; 888 end if; 889 end if; 890 891 P := P.Next; 892 end loop; 893 894 SSL.Unlock_Task.all; 895 896 exception 897 when others => 898 SSL.Unlock_Task.all; 899 raise; 900 end; 901 end if; 902 903 -- Open specified file if we did not find an existing stream 904 905 if Stream = NULL_Stream then 906 Fopen_Mode (Mode, Text, Creat, Amethod, Fopstr); 907 908 -- A special case, if we are opening (OPEN case) a file and 909 -- the mode returned by Fopen_Mode is not "r" or "r+", then 910 -- we first make sure that the file exists as required by 911 -- Ada semantics. 912 913 if Creat = False and then Fopstr (1) /= 'r' then 914 if file_exists (Namestr'Address) = 0 then 915 raise Name_Error; 916 end if; 917 end if; 918 919 -- Now open the file. Note that we use the name as given 920 -- in the original Open call for this purpose, since that 921 -- seems the clearest implementation of the intent. It 922 -- would presumably work to use the full name here, but 923 -- if there is any difference, then we should use the 924 -- name used in the call. 925 926 -- Note: for a corresponding delete, we will use the 927 -- full name, since by the time of the delete, the 928 -- current working directory may have changed and 929 -- we do not want to delete a different file! 930 931 Stream := fopen (Namestr'Address, Fopstr'Address); 932 933 if Stream = NULL_Stream then 934 if file_exists (Namestr'Address) = 0 then 935 raise Name_Error; 936 else 937 raise Use_Error; 938 end if; 939 end if; 940 end if; 941 end if; 942 943 -- Stream has been successfully located or opened, so now we are 944 -- committed to completing the opening of the file. Allocate block 945 -- on heap and fill in its fields. 946 947 File_Ptr := AFCB_Allocate (Dummy_FCB); 948 949 File_Ptr.Is_Regular_File := (is_regular_file 950 (fileno (Stream)) /= 0); 951 File_Ptr.Is_System_File := False; 952 File_Ptr.Is_Text_File := Text; 953 File_Ptr.Shared_Status := Shared; 954 File_Ptr.Access_Method := Amethod; 955 File_Ptr.Stream := Stream; 956 File_Ptr.Form := new String'(Formstr); 957 File_Ptr.Name := new String'(Fullname 958 (1 .. Full_Name_Len)); 959 File_Ptr.Mode := Mode; 960 File_Ptr.Is_Temporary_File := Tempfile; 961 962 Chain_File (File_Ptr); 963 Append_Set (File_Ptr); 964 end Open; 965 966 -------------- 967 -- Read_Buf -- 968 -------------- 969 970 procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is 971 Nread : size_t; 972 973 begin 974 Nread := fread (Buf, 1, Siz, File.Stream); 975 976 if Nread = Siz then 977 return; 978 979 elsif ferror (File.Stream) /= 0 then 980 raise Device_Error; 981 982 elsif Nread = 0 then 983 raise End_Error; 984 985 else -- 0 < Nread < Siz 986 raise Data_Error; 987 end if; 988 989 end Read_Buf; 990 991 procedure Read_Buf 992 (File : AFCB_Ptr; 993 Buf : Address; 994 Siz : in Interfaces.C_Streams.size_t; 995 Count : out Interfaces.C_Streams.size_t) 996 is 997 begin 998 Count := fread (Buf, 1, Siz, File.Stream); 999 1000 if Count = 0 and then ferror (File.Stream) /= 0 then 1001 raise Device_Error; 1002 end if; 1003 end Read_Buf; 1004 1005 ----------- 1006 -- Reset -- 1007 ----------- 1008 1009 -- The reset which does not change the mode simply does a rewind. 1010 1011 procedure Reset (File : in out AFCB_Ptr) is 1012 begin 1013 Check_File_Open (File); 1014 Reset (File, File.Mode); 1015 end Reset; 1016 1017 -- The reset with a change in mode is done using freopen, and is 1018 -- not permitted except for regular files (since otherwise there 1019 -- is no name for the freopen, and in any case it seems meaningless) 1020 1021 procedure Reset (File : in out AFCB_Ptr; Mode : in File_Mode) is 1022 Fopstr : aliased Fopen_String; 1023 1024 begin 1025 Check_File_Open (File); 1026 1027 -- Change of mode not allowed for shared file or file with no name 1028 -- or file that is not a regular file, or for a system file. 1029 1030 if File.Shared_Status = Yes 1031 or else File.Name'Length <= 1 1032 or else File.Is_System_File 1033 or else (not File.Is_Regular_File) 1034 then 1035 raise Use_Error; 1036 1037 -- For In_File or Inout_File for a regular file, we can just do a 1038 -- rewind if the mode is unchanged, which is more efficient than 1039 -- doing a full reopen. 1040 1041 elsif Mode = File.Mode 1042 and then Mode <= Inout_File 1043 then 1044 rewind (File.Stream); 1045 1046 -- Here the change of mode is permitted, we do it by reopening the 1047 -- file in the new mode and replacing the stream with a new stream. 1048 1049 else 1050 Fopen_Mode 1051 (Mode, File.Is_Text_File, False, File.Access_Method, Fopstr); 1052 1053 File.Stream := 1054 freopen (File.Name.all'Address, Fopstr'Address, File.Stream); 1055 1056 if File.Stream = NULL_Stream then 1057 Close (File); 1058 raise Use_Error; 1059 1060 else 1061 File.Mode := Mode; 1062 Append_Set (File); 1063 end if; 1064 end if; 1065 end Reset; 1066 1067 --------------- 1068 -- Write_Buf -- 1069 --------------- 1070 1071 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is 1072 begin 1073 -- Note: for most purposes, the Siz and 1 parameters in the fwrite 1074 -- call could be reversed, but on VMS, this is a better choice, since 1075 -- for some file formats, reversing the parameters results in records 1076 -- of one byte each. 1077 1078 SSL.Abort_Defer.all; 1079 1080 if fwrite (Buf, Siz, 1, File.Stream) /= 1 then 1081 if Siz /= 0 then 1082 SSL.Abort_Undefer.all; 1083 raise Device_Error; 1084 end if; 1085 end if; 1086 1087 SSL.Abort_Undefer.all; 1088 end Write_Buf; 1089 1090end System.File_IO; 1091