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