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