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