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