1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- A D A . D I R E C T O R I E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-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.Calendar; use Ada.Calendar; 33with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; 34with Ada.Characters.Handling; use Ada.Characters.Handling; 35with Ada.Directories.Validity; use Ada.Directories.Validity; 36with Ada.Strings.Fixed; 37with Ada.Strings.Maps; use Ada.Strings.Maps; 38with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 39with Ada.Unchecked_Deallocation; 40 41with System; use System; 42with System.CRTL; use System.CRTL; 43with System.File_Attributes; use System.File_Attributes; 44with System.File_IO; use System.File_IO; 45with System.OS_Constants; use System.OS_Constants; 46with System.OS_Lib; use System.OS_Lib; 47with System.Regexp; use System.Regexp; 48 49package body Ada.Directories is 50 51 type Dir_Type_Value is new Address; 52 -- This is the low-level address directory structure as returned by the C 53 -- opendir routine. 54 55 No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address); 56 -- Null directory value 57 58 Dir_Separator : constant Character; 59 pragma Import (C, Dir_Separator, "__gnat_dir_separator"); 60 -- Running system default directory separator 61 62 Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\"); 63 -- UNIX and DOS style directory separators 64 65 Max_Path : Integer; 66 pragma Import (C, Max_Path, "__gnat_max_path_len"); 67 -- The maximum length of a path 68 69 type Search_Data is record 70 Is_Valid : Boolean := False; 71 Name : Unbounded_String; 72 Pattern : Regexp; 73 Filter : Filter_Type; 74 Dir : Dir_Type_Value := No_Dir; 75 Entry_Fetched : Boolean := False; 76 Dir_Entry : Directory_Entry_Type; 77 end record; 78 -- The current state of a search 79 80 Empty_String : constant String := (1 .. 0 => ASCII.NUL); 81 -- Empty string, returned by function Extension when there is no extension 82 83 procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); 84 85 procedure Close (Dir : Dir_Type_Value); 86 87 function File_Exists (Name : String) return Boolean; 88 -- Returns True if the named file exists 89 90 procedure Fetch_Next_Entry (Search : Search_Type); 91 -- Get the next entry in a directory, setting Entry_Fetched if successful 92 -- or resetting Is_Valid if not. 93 94 --------------- 95 -- Base_Name -- 96 --------------- 97 98 function Base_Name (Name : String) return String is 99 Simple : constant String := Simple_Name (Name); 100 -- Simple'First is guaranteed to be 1 101 102 begin 103 -- Look for the last dot in the file name and return the part of the 104 -- file name preceding this last dot. If the first dot is the first 105 -- character of the file name, the base name is the empty string. 106 107 for Pos in reverse Simple'Range loop 108 if Simple (Pos) = '.' then 109 return Simple (1 .. Pos - 1); 110 end if; 111 end loop; 112 113 -- If there is no dot, return the complete file name 114 115 return Simple; 116 end Base_Name; 117 118 ----------- 119 -- Close -- 120 ----------- 121 122 procedure Close (Dir : Dir_Type_Value) is 123 Discard : Integer; 124 pragma Warnings (Off, Discard); 125 126 function closedir (directory : DIRs) return Integer; 127 pragma Import (C, closedir, "__gnat_closedir"); 128 129 begin 130 Discard := closedir (DIRs (Dir)); 131 end Close; 132 133 ------------- 134 -- Compose -- 135 ------------- 136 137 function Compose 138 (Containing_Directory : String := ""; 139 Name : String; 140 Extension : String := "") return String 141 is 142 Result : String (1 .. Containing_Directory'Length + 143 Name'Length + Extension'Length + 2); 144 Last : Natural; 145 146 begin 147 -- First, deal with the invalid cases 148 149 if Containing_Directory /= "" 150 and then not Is_Valid_Path_Name (Containing_Directory) 151 then 152 raise Name_Error with 153 "invalid directory path name """ & Containing_Directory & '"'; 154 155 elsif 156 Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) 157 then 158 raise Name_Error with 159 "invalid simple name """ & Name & '"'; 160 161 elsif Extension'Length /= 0 162 and then not Is_Valid_Simple_Name (Name & '.' & Extension) 163 then 164 raise Name_Error with 165 "invalid file name """ & Name & '.' & Extension & '"'; 166 167 -- This is not an invalid case so build the path name 168 169 else 170 Last := Containing_Directory'Length; 171 Result (1 .. Last) := Containing_Directory; 172 173 -- Add a directory separator if needed 174 175 if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then 176 Last := Last + 1; 177 Result (Last) := Dir_Separator; 178 end if; 179 180 -- Add the file name 181 182 Result (Last + 1 .. Last + Name'Length) := Name; 183 Last := Last + Name'Length; 184 185 -- If extension was specified, add dot followed by this extension 186 187 if Extension'Length /= 0 then 188 Last := Last + 1; 189 Result (Last) := '.'; 190 Result (Last + 1 .. Last + Extension'Length) := Extension; 191 Last := Last + Extension'Length; 192 end if; 193 194 return Result (1 .. Last); 195 end if; 196 end Compose; 197 198 -------------------------- 199 -- Containing_Directory -- 200 -------------------------- 201 202 function Containing_Directory (Name : String) return String is 203 begin 204 -- First, the invalid case 205 206 if not Is_Valid_Path_Name (Name) then 207 raise Name_Error with "invalid path name """ & Name & '"'; 208 209 else 210 declare 211 -- We need to resolve links because of A.16(47), since we must not 212 -- return alternative names for files. 213 214 Norm : constant String := Normalize_Pathname (Name); 215 Last_DS : constant Natural := 216 Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); 217 218 begin 219 if Last_DS = 0 then 220 221 -- There is no directory separator, returns current working 222 -- directory. 223 224 return Current_Directory; 225 226 -- If Name indicates a root directory, raise Use_Error, because 227 -- it has no containing directory. 228 229 elsif Norm = "/" 230 or else 231 (Windows 232 and then 233 (Norm = "\" 234 or else 235 (Norm'Length = 3 236 and then Norm (Norm'Last - 1 .. Norm'Last) = ":\" 237 and then (Norm (Norm'First) in 'a' .. 'z' 238 or else 239 Norm (Norm'First) in 'A' .. 'Z')))) 240 then 241 raise Use_Error with 242 "directory """ & Name & """ has no containing directory"; 243 244 else 245 declare 246 Last : Positive := Last_DS - Name'First + 1; 247 Result : String (1 .. Last); 248 249 begin 250 Result := Name (Name'First .. Last_DS); 251 252 -- Remove any trailing directory separator, except as the 253 -- first character or the first character following a drive 254 -- number on Windows. 255 256 while Last > 1 loop 257 exit when 258 Result (Last) /= '/' 259 and then 260 Result (Last) /= Directory_Separator; 261 262 exit when Windows 263 and then Last = 3 264 and then Result (2) = ':' 265 and then 266 (Result (1) in 'A' .. 'Z' 267 or else 268 Result (1) in 'a' .. 'z'); 269 270 Last := Last - 1; 271 end loop; 272 273 -- Special case of current directory, identified by "." 274 275 if Last = 1 and then Result (1) = '.' then 276 return Current_Directory; 277 278 -- Special case of "..": the current directory may be a root 279 -- directory. 280 281 elsif Last = 2 and then Result (1 .. 2) = ".." then 282 return Containing_Directory (Current_Directory); 283 284 else 285 return Result (1 .. Last); 286 end if; 287 end; 288 end if; 289 end; 290 end if; 291 end Containing_Directory; 292 293 --------------- 294 -- Copy_File -- 295 --------------- 296 297 procedure Copy_File 298 (Source_Name : String; 299 Target_Name : String; 300 Form : String := "") 301 is 302 Success : Boolean; 303 Mode : Copy_Mode := Overwrite; 304 Preserve : Attribute := None; 305 306 begin 307 -- First, the invalid cases 308 309 if not Is_Valid_Path_Name (Source_Name) then 310 raise Name_Error with 311 "invalid source path name """ & Source_Name & '"'; 312 313 elsif not Is_Valid_Path_Name (Target_Name) then 314 raise Name_Error with 315 "invalid target path name """ & Target_Name & '"'; 316 317 elsif not Is_Regular_File (Source_Name) then 318 raise Name_Error with '"' & Source_Name & """ is not a file"; 319 320 elsif Is_Directory (Target_Name) then 321 raise Use_Error with "target """ & Target_Name & """ is a directory"; 322 323 else 324 if Form'Length > 0 then 325 declare 326 Formstr : String (1 .. Form'Length + 1); 327 V1, V2 : Natural; 328 329 begin 330 -- Acquire form string, setting required NUL terminator 331 332 Formstr (1 .. Form'Length) := Form; 333 Formstr (Formstr'Last) := ASCII.NUL; 334 335 -- Convert form string to lower case 336 337 for J in Formstr'Range loop 338 if Formstr (J) in 'A' .. 'Z' then 339 Formstr (J) := 340 Character'Val (Character'Pos (Formstr (J)) + 32); 341 end if; 342 end loop; 343 344 -- Check Form 345 346 Form_Parameter (Formstr, "mode", V1, V2); 347 348 if V1 = 0 then 349 Mode := Overwrite; 350 elsif Formstr (V1 .. V2) = "copy" then 351 Mode := Copy; 352 elsif Formstr (V1 .. V2) = "overwrite" then 353 Mode := Overwrite; 354 elsif Formstr (V1 .. V2) = "append" then 355 Mode := Append; 356 else 357 raise Use_Error with "invalid Form"; 358 end if; 359 360 Form_Parameter (Formstr, "preserve", V1, V2); 361 362 if V1 = 0 then 363 Preserve := None; 364 elsif Formstr (V1 .. V2) = "timestamps" then 365 Preserve := Time_Stamps; 366 elsif Formstr (V1 .. V2) = "all_attributes" then 367 Preserve := Full; 368 elsif Formstr (V1 .. V2) = "no_attributes" then 369 Preserve := None; 370 else 371 raise Use_Error with "invalid Form"; 372 end if; 373 end; 374 end if; 375 376 -- Do actual copy using System.OS_Lib.Copy_File 377 378 Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); 379 380 if not Success then 381 raise Use_Error with "copy of """ & Source_Name & """ failed"; 382 end if; 383 end if; 384 end Copy_File; 385 386 ---------------------- 387 -- Create_Directory -- 388 ---------------------- 389 390 procedure Create_Directory 391 (New_Directory : String; 392 Form : String := "") 393 is 394 C_Dir_Name : constant String := New_Directory & ASCII.NUL; 395 396 begin 397 -- First, the invalid case 398 399 if not Is_Valid_Path_Name (New_Directory) then 400 raise Name_Error with 401 "invalid new directory path name """ & New_Directory & '"'; 402 403 else 404 -- Acquire setting of encoding parameter 405 406 declare 407 Formstr : constant String := To_Lower (Form); 408 409 Encoding : CRTL.Filename_Encoding; 410 -- Filename encoding specified into the form parameter 411 412 V1, V2 : Natural; 413 414 begin 415 Form_Parameter (Formstr, "encoding", V1, V2); 416 417 if V1 = 0 then 418 Encoding := CRTL.Unspecified; 419 elsif Formstr (V1 .. V2) = "utf8" then 420 Encoding := CRTL.UTF8; 421 elsif Formstr (V1 .. V2) = "8bits" then 422 Encoding := CRTL.ASCII_8bits; 423 else 424 raise Use_Error with "invalid Form"; 425 end if; 426 427 if CRTL.mkdir (C_Dir_Name, Encoding) /= 0 then 428 raise Use_Error with 429 "creation of new directory """ & New_Directory & """ failed"; 430 end if; 431 end; 432 end if; 433 end Create_Directory; 434 435 ----------------- 436 -- Create_Path -- 437 ----------------- 438 439 procedure Create_Path 440 (New_Directory : String; 441 Form : String := "") 442 is 443 New_Dir : String (1 .. New_Directory'Length + 1); 444 Last : Positive := 1; 445 Start : Positive := 1; 446 447 begin 448 -- First, the invalid case 449 450 if not Is_Valid_Path_Name (New_Directory) then 451 raise Name_Error with 452 "invalid new directory path name """ & New_Directory & '"'; 453 454 else 455 -- Build New_Dir with a directory separator at the end, so that the 456 -- complete path will be found in the loop below. 457 458 New_Dir (1 .. New_Directory'Length) := New_Directory; 459 New_Dir (New_Dir'Last) := Directory_Separator; 460 461 -- If host is windows, and the first two characters are directory 462 -- separators, we have an UNC path. Skip it. 463 464 if Directory_Separator = '\' 465 and then New_Dir'Length > 2 466 and then Is_In (New_Dir (1), Dir_Seps) 467 and then Is_In (New_Dir (2), Dir_Seps) 468 then 469 Start := 2; 470 loop 471 Start := Start + 1; 472 exit when Start = New_Dir'Last 473 or else Is_In (New_Dir (Start), Dir_Seps); 474 end loop; 475 end if; 476 477 -- Create, if necessary, each directory in the path 478 479 for J in Start + 1 .. New_Dir'Last loop 480 481 -- Look for the end of an intermediate directory 482 483 if not Is_In (New_Dir (J), Dir_Seps) then 484 Last := J; 485 486 -- We have found a new intermediate directory each time we find 487 -- a first directory separator. 488 489 elsif not Is_In (New_Dir (J - 1), Dir_Seps) then 490 491 -- No need to create the directory if it already exists 492 493 if Is_Directory (New_Dir (1 .. Last)) then 494 null; 495 496 -- It is an error if a file with such a name already exists 497 498 elsif Is_Regular_File (New_Dir (1 .. Last)) then 499 raise Use_Error with 500 "file """ & New_Dir (1 .. Last) & """ already exists"; 501 502 else 503 Create_Directory 504 (New_Directory => New_Dir (1 .. Last), Form => Form); 505 end if; 506 end if; 507 end loop; 508 end if; 509 end Create_Path; 510 511 ----------------------- 512 -- Current_Directory -- 513 ----------------------- 514 515 function Current_Directory return String is 516 Path_Len : Natural := Max_Path; 517 Buffer : String (1 .. 1 + Max_Path + 1); 518 519 procedure Local_Get_Current_Dir (Dir : Address; Length : Address); 520 pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); 521 522 begin 523 Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); 524 525 -- We need to resolve links because of RM A.16(47), which requires 526 -- that we not return alternative names for files. 527 528 return Normalize_Pathname (Buffer (1 .. Path_Len)); 529 end Current_Directory; 530 531 ---------------------- 532 -- Delete_Directory -- 533 ---------------------- 534 535 procedure Delete_Directory (Directory : String) is 536 begin 537 -- First, the invalid cases 538 539 if not Is_Valid_Path_Name (Directory) then 540 raise Name_Error with 541 "invalid directory path name """ & Directory & '"'; 542 543 elsif not Is_Directory (Directory) then 544 raise Name_Error with '"' & Directory & """ not a directory"; 545 546 -- Do the deletion, checking for error 547 548 else 549 declare 550 C_Dir_Name : constant String := Directory & ASCII.NUL; 551 begin 552 if rmdir (C_Dir_Name) /= 0 then 553 raise Use_Error with 554 "deletion of directory """ & Directory & """ failed"; 555 end if; 556 end; 557 end if; 558 end Delete_Directory; 559 560 ----------------- 561 -- Delete_File -- 562 ----------------- 563 564 procedure Delete_File (Name : String) is 565 Success : Boolean; 566 567 begin 568 -- First, the invalid cases 569 570 if not Is_Valid_Path_Name (Name) then 571 raise Name_Error with "invalid path name """ & Name & '"'; 572 573 elsif not Is_Regular_File (Name) 574 and then not Is_Symbolic_Link (Name) 575 then 576 raise Name_Error with "file """ & Name & """ does not exist"; 577 578 else 579 -- Do actual deletion using System.OS_Lib.Delete_File 580 581 Delete_File (Name, Success); 582 583 if not Success then 584 raise Use_Error with "file """ & Name & """ could not be deleted"; 585 end if; 586 end if; 587 end Delete_File; 588 589 ----------------- 590 -- Delete_Tree -- 591 ----------------- 592 593 procedure Delete_Tree (Directory : String) is 594 Current_Dir : constant String := Current_Directory; 595 Search : Search_Type; 596 Dir_Ent : Directory_Entry_Type; 597 begin 598 -- First, the invalid cases 599 600 if not Is_Valid_Path_Name (Directory) then 601 raise Name_Error with 602 "invalid directory path name """ & Directory & '"'; 603 604 elsif not Is_Directory (Directory) then 605 raise Name_Error with '"' & Directory & """ not a directory"; 606 607 else 608 Set_Directory (Directory); 609 610 Start_Search (Search, Directory => ".", Pattern => ""); 611 while More_Entries (Search) loop 612 Get_Next_Entry (Search, Dir_Ent); 613 614 declare 615 File_Name : constant String := Simple_Name (Dir_Ent); 616 617 begin 618 if OS_Lib.Is_Directory (File_Name) then 619 if File_Name /= "." and then File_Name /= ".." then 620 Delete_Tree (File_Name); 621 end if; 622 623 else 624 Delete_File (File_Name); 625 end if; 626 end; 627 end loop; 628 629 Set_Directory (Current_Dir); 630 End_Search (Search); 631 632 declare 633 C_Dir_Name : constant String := Directory & ASCII.NUL; 634 635 begin 636 if rmdir (C_Dir_Name) /= 0 then 637 raise Use_Error with 638 "directory tree rooted at """ & 639 Directory & """ could not be deleted"; 640 end if; 641 end; 642 end if; 643 end Delete_Tree; 644 645 ------------ 646 -- Exists -- 647 ------------ 648 649 function Exists (Name : String) return Boolean is 650 begin 651 -- First, the invalid case 652 653 if not Is_Valid_Path_Name (Name) then 654 raise Name_Error with "invalid path name """ & Name & '"'; 655 656 else 657 -- The implementation is in File_Exists 658 659 return File_Exists (Name); 660 end if; 661 end Exists; 662 663 --------------- 664 -- Extension -- 665 --------------- 666 667 function Extension (Name : String) return String is 668 begin 669 -- First, the invalid case 670 671 if not Is_Valid_Path_Name (Name) then 672 raise Name_Error with "invalid path name """ & Name & '"'; 673 674 else 675 -- Look for first dot that is not followed by a directory separator 676 677 for Pos in reverse Name'Range loop 678 679 -- If a directory separator is found before a dot, there is no 680 -- extension. 681 682 if Is_In (Name (Pos), Dir_Seps) then 683 return Empty_String; 684 685 elsif Name (Pos) = '.' then 686 687 -- We found a dot, build the return value with lower bound 1 688 689 declare 690 subtype Result_Type is String (1 .. Name'Last - Pos); 691 begin 692 return Result_Type (Name (Pos + 1 .. Name'Last)); 693 end; 694 end if; 695 end loop; 696 697 -- No dot were found, there is no extension 698 699 return Empty_String; 700 end if; 701 end Extension; 702 703 ---------------------- 704 -- Fetch_Next_Entry -- 705 ---------------------- 706 707 procedure Fetch_Next_Entry (Search : Search_Type) is 708 Name : String (1 .. NAME_MAX); 709 Last : Natural; 710 711 Kind : File_Kind := Ordinary_File; 712 -- Initialized to avoid a compilation warning 713 714 Filename_Addr : Address; 715 Filename_Len : aliased Integer; 716 717 Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character; 718 719 function readdir_gnat 720 (Directory : Address; 721 Buffer : Address; 722 Last : not null access Integer) return Address; 723 pragma Import (C, readdir_gnat, "__gnat_readdir"); 724 725 begin 726 -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called 727 728 loop 729 Filename_Addr := 730 readdir_gnat 731 (Address (Search.Value.Dir), 732 Buffer'Address, 733 Filename_Len'Access); 734 735 -- If no matching entry is found, set Is_Valid to False 736 737 if Filename_Addr = Null_Address then 738 Search.Value.Is_Valid := False; 739 exit; 740 end if; 741 742 if Filename_Len > Name'Length then 743 raise Use_Error with "file name too long"; 744 end if; 745 746 declare 747 subtype Name_String is String (1 .. Filename_Len); 748 Dent_Name : Name_String; 749 for Dent_Name'Address use Filename_Addr; 750 pragma Import (Ada, Dent_Name); 751 752 begin 753 Last := Filename_Len; 754 Name (1 .. Last) := Dent_Name; 755 end; 756 757 -- Check if the entry matches the pattern 758 759 if Match (Name (1 .. Last), Search.Value.Pattern) then 760 declare 761 C_Full_Name : constant String := 762 Compose (To_String (Search.Value.Name), 763 Name (1 .. Last)) & ASCII.NUL; 764 Full_Name : String renames 765 C_Full_Name 766 (C_Full_Name'First .. C_Full_Name'Last - 1); 767 Found : Boolean := False; 768 Attr : aliased File_Attributes; 769 Exists : Integer; 770 Error : Integer; 771 772 begin 773 Reset_Attributes (Attr'Access); 774 Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access); 775 Error := Error_Attributes (Attr'Access); 776 777 if Error /= 0 then 778 raise Use_Error 779 with Full_Name & ": " & Errno_Message (Err => Error); 780 end if; 781 782 if Exists = 1 then 783 784 -- Now check if the file kind matches the filter 785 786 if Is_Regular_File_Attr 787 (C_Full_Name'Address, Attr'Access) = 1 788 then 789 if Search.Value.Filter (Ordinary_File) then 790 Kind := Ordinary_File; 791 Found := True; 792 end if; 793 794 elsif Is_Directory_Attr 795 (C_Full_Name'Address, Attr'Access) = 1 796 then 797 if Search.Value.Filter (Directory) then 798 Kind := Directory; 799 Found := True; 800 end if; 801 802 elsif Search.Value.Filter (Special_File) then 803 Kind := Special_File; 804 Found := True; 805 end if; 806 807 -- If it does, update Search and return 808 809 if Found then 810 Search.Value.Entry_Fetched := True; 811 Search.Value.Dir_Entry := 812 (Is_Valid => True, 813 Simple => To_Unbounded_String (Name (1 .. Last)), 814 Full => To_Unbounded_String (Full_Name), 815 Kind => Kind); 816 exit; 817 end if; 818 end if; 819 end; 820 end if; 821 end loop; 822 end Fetch_Next_Entry; 823 824 ----------------- 825 -- File_Exists -- 826 ----------------- 827 828 function File_Exists (Name : String) return Boolean is 829 function C_File_Exists (A : Address) return Integer; 830 pragma Import (C, C_File_Exists, "__gnat_file_exists"); 831 832 C_Name : String (1 .. Name'Length + 1); 833 834 begin 835 C_Name (1 .. Name'Length) := Name; 836 C_Name (C_Name'Last) := ASCII.NUL; 837 return C_File_Exists (C_Name'Address) = 1; 838 end File_Exists; 839 840 -------------- 841 -- Finalize -- 842 -------------- 843 844 procedure Finalize (Search : in out Search_Type) is 845 begin 846 if Search.Value /= null then 847 848 -- Close the directory, if one is open 849 850 if Search.Value.Dir /= No_Dir then 851 Close (Search.Value.Dir); 852 end if; 853 854 Free (Search.Value); 855 end if; 856 end Finalize; 857 858 --------------- 859 -- Full_Name -- 860 --------------- 861 862 function Full_Name (Name : String) return String is 863 begin 864 -- First, the invalid case 865 866 if not Is_Valid_Path_Name (Name) then 867 raise Name_Error with "invalid path name """ & Name & '"'; 868 869 else 870 -- Build the return value with lower bound 1 871 872 -- Use System.OS_Lib.Normalize_Pathname 873 874 declare 875 -- We need to resolve links because of (RM A.16(47)), which says 876 -- we must not return alternative names for files. 877 878 Value : constant String := Normalize_Pathname (Name); 879 subtype Result is String (1 .. Value'Length); 880 881 begin 882 return Result (Value); 883 end; 884 end if; 885 end Full_Name; 886 887 function Full_Name (Directory_Entry : Directory_Entry_Type) return String is 888 begin 889 -- First, the invalid case 890 891 if not Directory_Entry.Is_Valid then 892 raise Status_Error with "invalid directory entry"; 893 894 else 895 -- The value to return has already been computed 896 897 return To_String (Directory_Entry.Full); 898 end if; 899 end Full_Name; 900 901 -------------------- 902 -- Get_Next_Entry -- 903 -------------------- 904 905 procedure Get_Next_Entry 906 (Search : in out Search_Type; 907 Directory_Entry : out Directory_Entry_Type) 908 is 909 begin 910 -- First, the invalid case 911 912 if Search.Value = null or else not Search.Value.Is_Valid then 913 raise Status_Error with "invalid search"; 914 end if; 915 916 -- Fetch the next entry, if needed 917 918 if not Search.Value.Entry_Fetched then 919 Fetch_Next_Entry (Search); 920 end if; 921 922 -- It is an error if no valid entry is found 923 924 if not Search.Value.Is_Valid then 925 raise Status_Error with "no next entry"; 926 927 else 928 -- Reset Entry_Fetched and return the entry 929 930 Search.Value.Entry_Fetched := False; 931 Directory_Entry := Search.Value.Dir_Entry; 932 end if; 933 end Get_Next_Entry; 934 935 ---------- 936 -- Kind -- 937 ---------- 938 939 function Kind (Name : String) return File_Kind is 940 begin 941 -- First, the invalid case 942 943 if not File_Exists (Name) then 944 raise Name_Error with "file """ & Name & """ does not exist"; 945 946 -- If OK, return appropriate kind 947 948 elsif Is_Regular_File (Name) then 949 return Ordinary_File; 950 951 elsif Is_Directory (Name) then 952 return Directory; 953 954 else 955 return Special_File; 956 end if; 957 end Kind; 958 959 function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is 960 begin 961 -- First, the invalid case 962 963 if not Directory_Entry.Is_Valid then 964 raise Status_Error with "invalid directory entry"; 965 966 else 967 -- The value to return has already be computed 968 969 return Directory_Entry.Kind; 970 end if; 971 end Kind; 972 973 ----------------------- 974 -- Modification_Time -- 975 ----------------------- 976 977 function Modification_Time (Name : String) return Time is 978 Date : OS_Time; 979 Year : Year_Type; 980 Month : Month_Type; 981 Day : Day_Type; 982 Hour : Hour_Type; 983 Minute : Minute_Type; 984 Second : Second_Type; 985 Result : Time; 986 987 begin 988 -- First, the invalid cases 989 990 if not (Is_Regular_File (Name) or else Is_Directory (Name)) then 991 raise Name_Error with '"' & Name & """ not a file or directory"; 992 993 else 994 Date := File_Time_Stamp (Name); 995 996 -- Break down the time stamp into its constituents relative to GMT. 997 -- This version of Split does not recognize leap seconds or buffer 998 -- space for time zone processing. 999 1000 GM_Split (Date, Year, Month, Day, Hour, Minute, Second); 1001 1002 -- On OpenVMS, the resulting time value must be in the local time 1003 -- zone. Ada.Calendar.Time_Of is exactly what we need. Note that 1004 -- in both cases, the sub seconds are set to zero (0.0) because the 1005 -- time stamp does not store them in its value. 1006 1007 if OpenVMS then 1008 Result := 1009 Ada.Calendar.Time_Of 1010 (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0)); 1011 1012 -- On Unix and Windows, the result must be in GMT. Ada.Calendar. 1013 -- Formatting.Time_Of with default time zone of zero (0) is the 1014 -- routine of choice. 1015 1016 else 1017 Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); 1018 end if; 1019 1020 return Result; 1021 end if; 1022 end Modification_Time; 1023 1024 function Modification_Time 1025 (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time 1026 is 1027 begin 1028 -- First, the invalid case 1029 1030 if not Directory_Entry.Is_Valid then 1031 raise Status_Error with "invalid directory entry"; 1032 1033 else 1034 -- The value to return has already be computed 1035 1036 return Modification_Time (To_String (Directory_Entry.Full)); 1037 end if; 1038 end Modification_Time; 1039 1040 ------------------ 1041 -- More_Entries -- 1042 ------------------ 1043 1044 function More_Entries (Search : Search_Type) return Boolean is 1045 begin 1046 if Search.Value = null then 1047 return False; 1048 1049 elsif Search.Value.Is_Valid then 1050 1051 -- Fetch the next entry, if needed 1052 1053 if not Search.Value.Entry_Fetched then 1054 Fetch_Next_Entry (Search); 1055 end if; 1056 end if; 1057 1058 return Search.Value.Is_Valid; 1059 end More_Entries; 1060 1061 ------------ 1062 -- Rename -- 1063 ------------ 1064 1065 procedure Rename (Old_Name, New_Name : String) is 1066 Success : Boolean; 1067 1068 begin 1069 -- First, the invalid cases 1070 1071 if not Is_Valid_Path_Name (Old_Name) then 1072 raise Name_Error with "invalid old path name """ & Old_Name & '"'; 1073 1074 elsif not Is_Valid_Path_Name (New_Name) then 1075 raise Name_Error with "invalid new path name """ & New_Name & '"'; 1076 1077 elsif not Is_Regular_File (Old_Name) 1078 and then not Is_Directory (Old_Name) 1079 then 1080 raise Name_Error with "old file """ & Old_Name & """ does not exist"; 1081 1082 elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then 1083 raise Use_Error with 1084 "new name """ & New_Name 1085 & """ designates a file that already exists"; 1086 1087 -- Do actual rename using System.OS_Lib.Rename_File 1088 1089 else 1090 Rename_File (Old_Name, New_Name, Success); 1091 1092 if not Success then 1093 1094 -- AI05-0231-1: Name_Error should be raised in case a directory 1095 -- component of New_Name does not exist (as in New_Name => 1096 -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT 1097 -- also indicate that the Old_Name does not exist, but we already 1098 -- checked for that above. All other errors are Use_Error. 1099 1100 if Errno = ENOENT then 1101 raise Name_Error with 1102 "file """ & Containing_Directory (New_Name) & """ not found"; 1103 1104 else 1105 raise Use_Error with 1106 "file """ & Old_Name & """ could not be renamed"; 1107 end if; 1108 end if; 1109 end if; 1110 end Rename; 1111 1112 ------------ 1113 -- Search -- 1114 ------------ 1115 1116 procedure Search 1117 (Directory : String; 1118 Pattern : String; 1119 Filter : Filter_Type := (others => True); 1120 Process : not null access procedure 1121 (Directory_Entry : Directory_Entry_Type)) 1122 is 1123 Srch : Search_Type; 1124 Directory_Entry : Directory_Entry_Type; 1125 1126 begin 1127 Start_Search (Srch, Directory, Pattern, Filter); 1128 while More_Entries (Srch) loop 1129 Get_Next_Entry (Srch, Directory_Entry); 1130 Process (Directory_Entry); 1131 end loop; 1132 1133 End_Search (Srch); 1134 end Search; 1135 1136 ------------------- 1137 -- Set_Directory -- 1138 ------------------- 1139 1140 procedure Set_Directory (Directory : String) is 1141 C_Dir_Name : constant String := Directory & ASCII.NUL; 1142 begin 1143 if not Is_Valid_Path_Name (Directory) then 1144 raise Name_Error with 1145 "invalid directory path name & """ & Directory & '"'; 1146 1147 elsif not Is_Directory (Directory) then 1148 raise Name_Error with 1149 "directory """ & Directory & """ does not exist"; 1150 1151 elsif chdir (C_Dir_Name) /= 0 then 1152 raise Name_Error with 1153 "could not set to designated directory """ & Directory & '"'; 1154 end if; 1155 end Set_Directory; 1156 1157 ----------------- 1158 -- Simple_Name -- 1159 ----------------- 1160 1161 function Simple_Name (Name : String) return String is 1162 1163 function Simple_Name_Internal (Path : String) return String; 1164 -- This function does the job 1165 1166 -------------------------- 1167 -- Simple_Name_Internal -- 1168 -------------------------- 1169 1170 function Simple_Name_Internal (Path : String) return String is 1171 Cut_Start : Natural := 1172 Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); 1173 Cut_End : Natural; 1174 1175 begin 1176 -- Cut_Start pointS to the first simple name character 1177 1178 Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); 1179 1180 -- Cut_End point to the last simple name character 1181 1182 Cut_End := Path'Last; 1183 1184 Check_For_Standard_Dirs : declare 1185 BN : constant String := Path (Cut_Start .. Cut_End); 1186 1187 Has_Drive_Letter : constant Boolean := 1188 OS_Lib.Path_Separator /= ':'; 1189 -- If Path separator is not ':' then we are on a DOS based OS 1190 -- where this character is used as a drive letter separator. 1191 1192 begin 1193 if BN = "." or else BN = ".." then 1194 return ""; 1195 1196 elsif Has_Drive_Letter 1197 and then BN'Length > 2 1198 and then Characters.Handling.Is_Letter (BN (BN'First)) 1199 and then BN (BN'First + 1) = ':' 1200 then 1201 -- We have a DOS drive letter prefix, remove it 1202 1203 return BN (BN'First + 2 .. BN'Last); 1204 1205 else 1206 return BN; 1207 end if; 1208 end Check_For_Standard_Dirs; 1209 end Simple_Name_Internal; 1210 1211 -- Start of processing for Simple_Name 1212 1213 begin 1214 -- First, the invalid case 1215 1216 if not Is_Valid_Path_Name (Name) then 1217 raise Name_Error with "invalid path name """ & Name & '"'; 1218 1219 else 1220 -- Build the value to return with lower bound 1 1221 1222 declare 1223 Value : constant String := Simple_Name_Internal (Name); 1224 subtype Result is String (1 .. Value'Length); 1225 begin 1226 return Result (Value); 1227 end; 1228 end if; 1229 end Simple_Name; 1230 1231 function Simple_Name 1232 (Directory_Entry : Directory_Entry_Type) return String is 1233 begin 1234 -- First, the invalid case 1235 1236 if not Directory_Entry.Is_Valid then 1237 raise Status_Error with "invalid directory entry"; 1238 1239 else 1240 -- The value to return has already be computed 1241 1242 return To_String (Directory_Entry.Simple); 1243 end if; 1244 end Simple_Name; 1245 1246 ---------- 1247 -- Size -- 1248 ---------- 1249 1250 function Size (Name : String) return File_Size is 1251 C_Name : String (1 .. Name'Length + 1); 1252 1253 function C_Size (Name : Address) return Long_Integer; 1254 pragma Import (C, C_Size, "__gnat_named_file_length"); 1255 1256 begin 1257 -- First, the invalid case 1258 1259 if not Is_Regular_File (Name) then 1260 raise Name_Error with "file """ & Name & """ does not exist"; 1261 1262 else 1263 C_Name (1 .. Name'Length) := Name; 1264 C_Name (C_Name'Last) := ASCII.NUL; 1265 return File_Size (C_Size (C_Name'Address)); 1266 end if; 1267 end Size; 1268 1269 function Size (Directory_Entry : Directory_Entry_Type) return File_Size is 1270 begin 1271 -- First, the invalid case 1272 1273 if not Directory_Entry.Is_Valid then 1274 raise Status_Error with "invalid directory entry"; 1275 1276 else 1277 -- The value to return has already be computed 1278 1279 return Size (To_String (Directory_Entry.Full)); 1280 end if; 1281 end Size; 1282 1283 ------------------ 1284 -- Start_Search -- 1285 ------------------ 1286 1287 procedure Start_Search 1288 (Search : in out Search_Type; 1289 Directory : String; 1290 Pattern : String; 1291 Filter : Filter_Type := (others => True)) 1292 is 1293 function opendir (file_name : String) return DIRs; 1294 pragma Import (C, opendir, "__gnat_opendir"); 1295 1296 C_File_Name : constant String := Directory & ASCII.NUL; 1297 Pat : Regexp; 1298 Dir : Dir_Type_Value; 1299 1300 begin 1301 -- First, the invalid case Name_Error 1302 1303 if not Is_Directory (Directory) then 1304 raise Name_Error with 1305 "unknown directory """ & Simple_Name (Directory) & '"'; 1306 end if; 1307 1308 -- Check the pattern 1309 1310 begin 1311 Pat := Compile 1312 (Pattern, 1313 Glob => True, 1314 Case_Sensitive => Is_Path_Name_Case_Sensitive); 1315 exception 1316 when Error_In_Regexp => 1317 Free (Search.Value); 1318 raise Name_Error with "invalid pattern """ & Pattern & '"'; 1319 end; 1320 1321 Dir := Dir_Type_Value (opendir (C_File_Name)); 1322 1323 if Dir = No_Dir then 1324 raise Use_Error with 1325 "unreadable directory """ & Simple_Name (Directory) & '"'; 1326 end if; 1327 1328 -- If needed, finalize Search 1329 1330 Finalize (Search); 1331 1332 -- Allocate the default data 1333 1334 Search.Value := new Search_Data; 1335 1336 -- Initialize some Search components 1337 1338 Search.Value.Filter := Filter; 1339 Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); 1340 Search.Value.Pattern := Pat; 1341 Search.Value.Dir := Dir; 1342 Search.Value.Is_Valid := True; 1343 end Start_Search; 1344 1345end Ada.Directories; 1346