gcc/ada/a-direct.adb

   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-2005, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Directories.Validity;   use Ada.Directories.Validity;
  35 with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;
  36 with Ada.Unchecked_Deallocation;
  37 with Ada.Unchecked_Conversion;
  38 with Ada.Characters.Handling;    use Ada.Characters.Handling;
  39
  40 with GNAT.Directory_Operations;  use GNAT.Directory_Operations;
  41 with GNAT.OS_Lib;                use GNAT.OS_Lib;
  42 with GNAT.Regexp;                use GNAT.Regexp;
  43 --  ??? Ada units should not depend on GNAT units
  44
  45 with System;
  46
  47 package body Ada.Directories is
  48
  49    function Duration_To_Time is new
  50      Ada.Unchecked_Conversion (Duration, Ada.Calendar.Time);
  51    function OS_Time_To_Long_Integer is new
  52      Ada.Unchecked_Conversion (OS_Time, Long_Integer);
  53    --  These two unchecked conversions are used in function Modification_Time
  54    --  to convert an OS_Time to a Calendar.Time.
  55
  56    type Search_Data is record
  57       Is_Valid      : Boolean := False;
  58       Name          : Ada.Strings.Unbounded.Unbounded_String;
  59       Pattern       : Regexp;
  60       Filter        : Filter_Type;
  61       Dir           : Dir_Type;
  62       Entry_Fetched : Boolean := False;
  63       Dir_Entry     : Directory_Entry_Type;
  64    end record;
  65    --  The current state of a search
  66
  67    Empty_String : constant String := (1 .. 0 => ASCII.NUL);
  68    --  Empty string, returned by function Extension when there is no extension
  69
  70    procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
  71
  72    function File_Exists (Name : String) return Boolean;
  73    --  Returns True if the named file exists
  74
  75    procedure Fetch_Next_Entry (Search : Search_Type);
  76    --  Get the next entry in a directory, setting Entry_Fetched if successful
  77    --  or resetting Is_Valid if not.
  78
  79    procedure To_Lower_If_Case_Insensitive (S : in out String);
  80    --  Put S in lower case if file and path names are case-insensitive
  81
  82    ---------------
  83    -- Base_Name --
  84    ---------------
  85
  86    function Base_Name (Name : String) return String is
  87       Simple : String := Simple_Name (Name);
  88       --  Simple'First is guaranteed to be 1
  89
  90    begin
  91       To_Lower_If_Case_Insensitive (Simple);
  92
  93       --  Look for the last dot in the file name and return the part of the
  94       --  file name preceding this last dot. If the first dot is the first
  95       --  character of the file name, the base name is the empty string.
  96
  97       for Pos in reverse Simple'Range loop
  98          if Simple (Pos) = '.' then
  99             return Simple (1 .. Pos - 1);
 100          end if;
 101       end loop;
 102
 103       --  If there is no dot, return the complete file name
 104
 105       return Simple;
 106    end Base_Name;
 107
 108    -------------
 109    -- Compose --
 110    -------------
 111
 112    function Compose
 113      (Containing_Directory : String := "";
 114       Name                 : String;
 115       Extension            : String := "") return String
 116    is
 117       Result : String (1 .. Containing_Directory'Length +
 118                               Name'Length + Extension'Length + 2);
 119       Last   : Natural;
 120
 121    begin
 122       --  First, deal with the invalid cases
 123
 124       if not Is_Valid_Path_Name (Containing_Directory) then
 125          raise Name_Error;
 126
 127       elsif
 128         Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
 129       then
 130          raise Name_Error;
 131
 132       elsif Extension'Length /= 0 and then
 133         (not Is_Valid_Simple_Name (Name & '.' & Extension))
 134       then
 135          raise Name_Error;
 136
 137          --  This is not an invalid case so build the path name
 138
 139       else
 140          Last := Containing_Directory'Length;
 141          Result (1 .. Last) := Containing_Directory;
 142
 143          --  Add a directory separator if needed
 144
 145          if Result (Last) /= Dir_Separator then
 146             Last := Last + 1;
 147             Result (Last) := Dir_Separator;
 148          end if;
 149
 150          --  Add the file name
 151
 152          Result (Last + 1 .. Last + Name'Length) := Name;
 153          Last := Last + Name'Length;
 154
 155          --  If extension was specified, add dot followed by this extension
 156
 157          if Extension'Length /= 0 then
 158             Last := Last + 1;
 159             Result (Last) := '.';
 160             Result (Last + 1 .. Last + Extension'Length) := Extension;
 161             Last := Last + Extension'Length;
 162          end if;
 163
 164          To_Lower_If_Case_Insensitive (Result (1 .. Last));
 165          return Result (1 .. Last);
 166       end if;
 167    end Compose;
 168
 169    --------------------------
 170    -- Containing_Directory --
 171    --------------------------
 172
 173    function Containing_Directory (Name : String) return String is
 174    begin
 175       --  First, the invalid case
 176
 177       if not Is_Valid_Path_Name (Name) then
 178          raise Name_Error;
 179
 180       else
 181          --  Get the directory name using GNAT.Directory_Operations.Dir_Name
 182
 183          declare
 184             Value : constant String := Dir_Name (Path => Name);
 185             Result : String (1 .. Value'Length);
 186             Last : Natural := Result'Last;
 187
 188          begin
 189             Result := Value;
 190
 191             --  Remove any trailing directory separator, except as the first
 192             --  character.
 193
 194             while Last > 1 and then Result (Last) = Dir_Separator loop
 195                Last := Last - 1;
 196             end loop;
 197
 198             --  Special case of current directory, identified by "."
 199
 200             if Last = 1 and then Result (1) = '.' then
 201                return Get_Current_Dir;
 202
 203             else
 204                To_Lower_If_Case_Insensitive (Result (1 .. Last));
 205                return Result (1 .. Last);
 206             end if;
 207          end;
 208       end if;
 209    end Containing_Directory;
 210
 211    ---------------
 212    -- Copy_File --
 213    ---------------
 214
 215    procedure Copy_File
 216      (Source_Name   : String;
 217       Target_Name   : String;
 218       Form          : String := "")
 219    is
 220       pragma Unreferenced (Form);
 221       Success : Boolean;
 222
 223    begin
 224       --  First, the invalid cases
 225
 226       if not Is_Valid_Path_Name (Source_Name)
 227         or else not Is_Valid_Path_Name (Target_Name)
 228         or else not Is_Regular_File (Source_Name)
 229       then
 230          raise Name_Error;
 231
 232       elsif Is_Directory (Target_Name) then
 233          raise Use_Error;
 234
 235       else
 236          --  The implementation uses GNAT.OS_Lib.Copy_File, with parameters
 237          --  suitable for all platforms.
 238
 239          Copy_File
 240            (Source_Name, Target_Name, Success, Overwrite, None);
 241
 242          if not Success then
 243             raise Use_Error;
 244          end if;
 245       end if;
 246    end Copy_File;
 247
 248    ----------------------
 249    -- Create_Directory --
 250    ----------------------
 251
 252    procedure Create_Directory
 253      (New_Directory : String;
 254       Form          : String := "")
 255    is
 256       pragma Unreferenced (Form);
 257
 258    begin
 259       --  First, the invalid case
 260
 261       if not Is_Valid_Path_Name (New_Directory) then
 262          raise Name_Error;
 263
 264       else
 265          --  The implementation uses GNAT.Directory_Operations.Make_Dir
 266
 267          begin
 268             Make_Dir (Dir_Name => New_Directory);
 269
 270          exception
 271             when Directory_Error =>
 272                raise Use_Error;
 273          end;
 274       end if;
 275    end Create_Directory;
 276
 277    -----------------
 278    -- Create_Path --
 279    -----------------
 280
 281    procedure Create_Path
 282      (New_Directory : String;
 283       Form          : String := "")
 284    is
 285       pragma Unreferenced (Form);
 286
 287       New_Dir : String (1 .. New_Directory'Length + 1);
 288       Last    : Positive := 1;
 289
 290    begin
 291       --  First, the invalid case
 292
 293       if not Is_Valid_Path_Name (New_Directory) then
 294          raise Name_Error;
 295
 296       else
 297          --  Build New_Dir with a directory separator at the end, so that the
 298          --  complete path will be found in the loop below.
 299
 300          New_Dir (1 .. New_Directory'Length) := New_Directory;
 301          New_Dir (New_Dir'Last) := Directory_Separator;
 302
 303          --  Create, if necessary, each directory in the path
 304
 305          for J in 2 .. New_Dir'Last loop
 306
 307             --  Look for the end of an intermediate directory
 308
 309             if New_Dir (J) /= Dir_Separator then
 310                Last := J;
 311
 312             --  We have found a new intermediate directory each time we find
 313             --  a first directory separator.
 314
 315             elsif New_Dir (J - 1) /= Dir_Separator then
 316
 317                --  No need to create the directory if it already exists
 318
 319                if Is_Directory (New_Dir (1 .. Last)) then
 320                   null;
 321
 322                --  It is an error if a file with such a name already exists
 323
 324                elsif Is_Regular_File (New_Dir (1 .. Last)) then
 325                   raise Use_Error;
 326
 327                else
 328                   --  The implementation uses
 329                   --  GNAT.Directory_Operations.Make_Dir.
 330
 331                   begin
 332                      Make_Dir (Dir_Name => New_Dir (1 .. Last));
 333
 334                   exception
 335                      when Directory_Error =>
 336                         raise Use_Error;
 337                   end;
 338                end if;
 339             end if;
 340          end loop;
 341       end if;
 342    end Create_Path;
 343
 344    -----------------------
 345    -- Current_Directory --
 346    -----------------------
 347
 348    function Current_Directory return String is
 349
 350       --  The implementation uses GNAT.Directory_Operations.Get_Current_Dir
 351
 352       Cur : String := Normalize_Pathname (Get_Current_Dir);
 353
 354    begin
 355       To_Lower_If_Case_Insensitive (Cur);
 356
 357       if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
 358          return Cur (1 .. Cur'Last - 1);
 359       else
 360          return Cur;
 361       end if;
 362    end Current_Directory;
 363
 364    ----------------------
 365    -- Delete_Directory --
 366    ----------------------
 367
 368    procedure Delete_Directory (Directory : String) is
 369    begin
 370       --  First, the invalid cases
 371
 372       if not Is_Valid_Path_Name (Directory) then
 373          raise Name_Error;
 374
 375       elsif not Is_Directory (Directory) then
 376          raise Name_Error;
 377
 378       else
 379          --  The implementation uses GNAT.Directory_Operations.Remove_Dir
 380
 381          begin
 382             Remove_Dir (Dir_Name => Directory, Recursive => False);
 383
 384          exception
 385             when Directory_Error =>
 386                raise Use_Error;
 387          end;
 388       end if;
 389    end Delete_Directory;
 390
 391    -----------------
 392    -- Delete_File --
 393    -----------------
 394
 395    procedure Delete_File (Name : String) is
 396       Success : Boolean;
 397
 398    begin
 399       --  First, the invalid cases
 400
 401       if not Is_Valid_Path_Name (Name) then
 402          raise Name_Error;
 403
 404       elsif not Is_Regular_File (Name) then
 405          raise Name_Error;
 406
 407       else
 408          --  The implementation uses GNAT.OS_Lib.Delete_File
 409
 410          Delete_File (Name, Success);
 411
 412          if not Success then
 413             raise Use_Error;
 414          end if;
 415       end if;
 416    end Delete_File;
 417
 418    -----------------
 419    -- Delete_Tree --
 420    -----------------
 421
 422    procedure Delete_Tree (Directory : String) is
 423    begin
 424       --  First, the invalid cases
 425
 426       if not Is_Valid_Path_Name (Directory) then
 427          raise Name_Error;
 428
 429       elsif not Is_Directory (Directory) then
 430          raise Name_Error;
 431
 432       else
 433          --  The implementation uses GNAT.Directory_Operations.Remove_Dir
 434
 435          begin
 436             Remove_Dir (Directory, Recursive => True);
 437
 438          exception
 439             when Directory_Error =>
 440                raise Use_Error;
 441          end;
 442       end if;
 443    end Delete_Tree;
 444
 445    ------------
 446    -- Exists --
 447    ------------
 448
 449    function Exists (Name : String) return Boolean is
 450    begin
 451       --  First, the invalid case
 452
 453       if not Is_Valid_Path_Name (Name) then
 454          raise Name_Error;
 455
 456       else
 457          --  The implementation is in File_Exists
 458
 459          return File_Exists (Name);
 460       end if;
 461    end Exists;
 462
 463    ---------------
 464    -- Extension --
 465    ---------------
 466
 467    function Extension (Name : String) return String is
 468    begin
 469       --  First, the invalid case
 470
 471       if not Is_Valid_Path_Name (Name) then
 472          raise Name_Error;
 473
 474       else
 475          --  Look for first dot that is not followed by a directory separator
 476
 477          for Pos in reverse Name'Range loop
 478
 479             --  If a directory separator is found before a dot, there
 480             --  is no extension.
 481
 482             if Name (Pos) = Dir_Separator then
 483                return Empty_String;
 484
 485             elsif Name (Pos) = '.' then
 486
 487                --  We found a dot, build the return value with lower bound 1
 488
 489                declare
 490                   Result : String (1 .. Name'Last - Pos);
 491                begin
 492                   Result := Name (Pos + 1 .. Name'Last);
 493                   return Result;
 494                   --  This should be done with a subtype conversion, avoiding
 495                   --  the unnecessary junk copy ???
 496                end;
 497             end if;
 498          end loop;
 499
 500          --  No dot were found, there is no extension
 501
 502          return Empty_String;
 503       end if;
 504    end Extension;
 505
 506    ----------------------
 507    -- Fetch_Next_Entry --
 508    ----------------------
 509
 510    procedure Fetch_Next_Entry (Search : Search_Type) is
 511       Name : String (1 .. 255);
 512       Last : Natural;
 513
 514       Kind : File_Kind := Ordinary_File;
 515       --  Initialized to avoid a compilation warning
 516
 517    begin
 518       --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
 519
 520       loop
 521          Read (Search.Value.Dir, Name, Last);
 522
 523          --  If no matching entry is found, set Is_Valid to False
 524
 525          if Last = 0 then
 526             Search.Value.Is_Valid := False;
 527             exit;
 528          end if;
 529
 530          --  Check if the entry matches the pattern
 531
 532          if Match (Name (1 .. Last), Search.Value.Pattern) then
 533             declare
 534                Full_Name : constant String :=
 535                              Compose
 536                                (To_String
 537                                   (Search.Value.Name), Name (1 .. Last));
 538                Found     : Boolean := False;
 539
 540             begin
 541                if File_Exists (Full_Name) then
 542
 543                   --  Now check if the file kind matches the filter
 544
 545                   if Is_Regular_File (Full_Name) then
 546                      if Search.Value.Filter (Ordinary_File) then
 547                         Kind := Ordinary_File;
 548                         Found := True;
 549                      end if;
 550
 551                   elsif Is_Directory (Full_Name) then
 552                      if Search.Value.Filter (Directory) then
 553                         Kind := Directory;
 554                         Found := True;
 555                      end if;
 556
 557                   elsif Search.Value.Filter (Special_File) then
 558                      Kind := Special_File;
 559                      Found := True;
 560                   end if;
 561
 562                   --  If it does, update Search and return
 563
 564                   if Found then
 565                      Search.Value.Entry_Fetched := True;
 566                      Search.Value.Dir_Entry :=
 567                        (Is_Valid => True,
 568                         Simple   => To_Unbounded_String (Name (1 .. Last)),
 569                         Full     => To_Unbounded_String (Full_Name),
 570                         Kind     => Kind);
 571                      exit;
 572                   end if;
 573                end if;
 574             end;
 575          end if;
 576       end loop;
 577    end Fetch_Next_Entry;
 578
 579    -----------------
 580    -- File_Exists --
 581    -----------------
 582
 583    function File_Exists (Name : String) return Boolean is
 584       function C_File_Exists (A : System.Address) return Integer;
 585       pragma Import (C, C_File_Exists, "__gnat_file_exists");
 586
 587       C_Name : String (1 .. Name'Length + 1);
 588
 589    begin
 590       C_Name (1 .. Name'Length) := Name;
 591       C_Name (C_Name'Last) := ASCII.NUL;
 592       return C_File_Exists (C_Name (1)'Address) = 1;
 593    end File_Exists;
 594
 595    --------------
 596    -- Finalize --
 597    --------------
 598
 599    procedure Finalize (Search : in out Search_Type) is
 600    begin
 601       if Search.Value /= null then
 602
 603          --  Close the directory, if one is open
 604
 605          if Is_Open (Search.Value.Dir) then
 606             Close (Search.Value.Dir);
 607          end if;
 608
 609          Free (Search.Value);
 610       end if;
 611    end Finalize;
 612
 613    ---------------
 614    -- Full_Name --
 615    ---------------
 616
 617    function Full_Name (Name : String) return String is
 618    begin
 619       --  First, the invalid case
 620
 621       if not Is_Valid_Path_Name (Name) then
 622          raise Name_Error;
 623
 624       else
 625          --  Build the return value with lower bound 1
 626
 627          --  Use GNAT.OS_Lib.Normalize_Pathname
 628
 629          declare
 630             Value : String := Normalize_Pathname (Name);
 631             subtype Result is String (1 .. Value'Length);
 632          begin
 633             To_Lower_If_Case_Insensitive (Value);
 634             return Result (Value);
 635          end;
 636       end if;
 637    end Full_Name;
 638
 639    function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
 640    begin
 641       --  First, the invalid case
 642
 643       if not Directory_Entry.Is_Valid then
 644          raise Status_Error;
 645
 646       else
 647          --  The value to return has already been computed
 648
 649          return To_String (Directory_Entry.Full);
 650       end if;
 651    end Full_Name;
 652
 653    --------------------
 654    -- Get_Next_Entry --
 655    --------------------
 656
 657    procedure Get_Next_Entry
 658      (Search          : in out Search_Type;
 659       Directory_Entry : out Directory_Entry_Type)
 660    is
 661    begin
 662       --  First, the invalid case
 663
 664       if Search.Value = null or else not Search.Value.Is_Valid then
 665          raise Status_Error;
 666       end if;
 667
 668       --  Fetch the next entry, if needed
 669
 670       if not Search.Value.Entry_Fetched then
 671          Fetch_Next_Entry (Search);
 672       end if;
 673
 674       --  It is an error if no valid entry is found
 675
 676       if not Search.Value.Is_Valid then
 677          raise Status_Error;
 678
 679       else
 680          --  Reset Entry_Fatched and return the entry
 681
 682          Search.Value.Entry_Fetched := False;
 683          Directory_Entry := Search.Value.Dir_Entry;
 684       end if;
 685    end Get_Next_Entry;
 686
 687    ----------
 688    -- Kind --
 689    ----------
 690
 691    function Kind (Name : String) return File_Kind is
 692    begin
 693       --  First, the invalid case
 694
 695       if not File_Exists (Name) then
 696          raise Name_Error;
 697
 698       elsif Is_Regular_File (Name) then
 699          return Ordinary_File;
 700
 701       elsif Is_Directory (Name) then
 702          return Directory;
 703
 704       else
 705          return Special_File;
 706       end if;
 707    end Kind;
 708
 709    function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
 710    begin
 711       --  First, the invalid case
 712
 713       if not Directory_Entry.Is_Valid then
 714          raise Status_Error;
 715
 716       else
 717          --  The value to return has already be computed
 718
 719          return Directory_Entry.Kind;
 720       end if;
 721    end Kind;
 722
 723    -----------------------
 724    -- Modification_Time --
 725    -----------------------
 726
 727    function Modification_Time (Name : String) return Ada.Calendar.Time is
 728       Date   : OS_Time;
 729       Year   : Year_Type;
 730       Month  : Month_Type;
 731       Day    : Day_Type;
 732       Hour   : Hour_Type;
 733       Minute : Minute_Type;
 734       Second : Second_Type;
 735
 736       Result : Ada.Calendar.Time;
 737
 738    begin
 739       --  First, the invalid cases
 740
 741       if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
 742          raise Name_Error;
 743
 744       else
 745          Date := File_Time_Stamp (Name);
 746
 747          --  ??? This implementation should be revisited when AI 00351 has
 748          --  implemented.
 749
 750          if OpenVMS then
 751
 752             --  On OpenVMS, OS_Time is in local time
 753
 754             GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
 755
 756             return Ada.Calendar.Time_Of
 757               (Year, Month, Day,
 758                Duration (Second + 60 * (Minute + 60 * Hour)));
 759
 760          else
 761             --  On Unix and Windows, OS_Time is in GMT
 762
 763             Result :=
 764               Duration_To_Time (Duration (OS_Time_To_Long_Integer (Date)));
 765             return Result;
 766          end if;
 767       end if;
 768    end Modification_Time;
 769
 770    function Modification_Time
 771      (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
 772    is
 773    begin
 774       --  First, the invalid case
 775
 776       if not Directory_Entry.Is_Valid then
 777          raise Status_Error;
 778
 779       else
 780          --  The value to return has already be computed
 781
 782          return Modification_Time (To_String (Directory_Entry.Full));
 783       end if;
 784    end Modification_Time;
 785
 786    ------------------
 787    -- More_Entries --
 788    ------------------
 789
 790    function More_Entries (Search : Search_Type) return Boolean is
 791    begin
 792       if Search.Value = null then
 793          return False;
 794
 795       elsif Search.Value.Is_Valid then
 796
 797          --  Fetch the next entry, if needed
 798
 799          if not Search.Value.Entry_Fetched then
 800             Fetch_Next_Entry (Search);
 801          end if;
 802       end if;
 803
 804       return Search.Value.Is_Valid;
 805    end More_Entries;
 806
 807    ------------
 808    -- Rename --
 809    ------------
 810
 811    procedure Rename (Old_Name, New_Name : String) is
 812       Success : Boolean;
 813
 814    begin
 815       --  First, the invalid cases
 816
 817       if not Is_Valid_Path_Name (Old_Name)
 818         or else not Is_Valid_Path_Name (New_Name)
 819         or else (not Is_Regular_File (Old_Name)
 820                    and then not Is_Directory (Old_Name))
 821       then
 822          raise Name_Error;
 823
 824       elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
 825          raise Use_Error;
 826
 827       else
 828          --  The implementation uses GNAT.OS_Lib.Rename_File
 829
 830          Rename_File (Old_Name, New_Name, Success);
 831
 832          if not Success then
 833             raise Use_Error;
 834          end if;
 835       end if;
 836    end Rename;
 837
 838    -------------------
 839    -- Set_Directory --
 840    -------------------
 841
 842    procedure Set_Directory (Directory : String) is
 843    begin
 844       --  The implementation uses GNAT.Directory_Operations.Change_Dir
 845
 846       Change_Dir (Dir_Name => Directory);
 847
 848    exception
 849       when Directory_Error =>
 850          raise Name_Error;
 851    end Set_Directory;
 852
 853    -----------------
 854    -- Simple_Name --
 855    -----------------
 856
 857    function Simple_Name (Name : String) return String is
 858    begin
 859       --  First, the invalid case
 860
 861       if not Is_Valid_Path_Name (Name) then
 862          raise Name_Error;
 863
 864       else
 865          --  Build the value to return with lower bound 1
 866
 867          --  The implementation uses GNAT.Directory_Operations.Base_Name
 868
 869          declare
 870             Value  : String := GNAT.Directory_Operations.Base_Name (Name);
 871             subtype Result is String (1 .. Value'Length);
 872          begin
 873             To_Lower_If_Case_Insensitive (Value);
 874             return Result (Value);
 875          end;
 876       end if;
 877    end Simple_Name;
 878
 879    function Simple_Name
 880      (Directory_Entry : Directory_Entry_Type) return String
 881    is
 882    begin
 883       --  First, the invalid case
 884
 885       if not Directory_Entry.Is_Valid then
 886          raise Status_Error;
 887
 888       else
 889          --  The value to return has already be computed
 890
 891          return To_String (Directory_Entry.Simple);
 892       end if;
 893    end Simple_Name;
 894
 895    ----------
 896    -- Size --
 897    ----------
 898
 899    function Size (Name : String) return File_Size is
 900       C_Name : String (1 .. Name'Length + 1);
 901
 902       function C_Size (Name : System.Address) return Long_Integer;
 903       pragma Import (C, C_Size, "__gnat_named_file_length");
 904
 905    begin
 906       --  First, the invalid case
 907
 908       if not Is_Regular_File (Name) then
 909          raise Name_Error;
 910
 911       else
 912          C_Name (1 .. Name'Length) := Name;
 913          C_Name (C_Name'Last) := ASCII.NUL;
 914          return File_Size (C_Size (C_Name'Address));
 915       end if;
 916    end Size;
 917
 918    function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
 919    begin
 920       --  First, the invalid case
 921
 922       if not Directory_Entry.Is_Valid then
 923          raise Status_Error;
 924
 925       else
 926          --  The value to return has already be computed
 927
 928          return Size (To_String (Directory_Entry.Full));
 929       end if;
 930    end Size;
 931
 932    ------------------
 933    -- Start_Search --
 934    ------------------
 935
 936    procedure Start_Search
 937      (Search    : in out Search_Type;
 938       Directory : String;
 939       Pattern   : String;
 940       Filter    : Filter_Type := (others => True))
 941    is
 942    begin
 943       --  First, the invalid case
 944
 945       if not Is_Directory (Directory) then
 946          raise Name_Error;
 947       end if;
 948
 949       --  If needed, finalize Search
 950
 951       Finalize (Search);
 952
 953       --  Allocate the default data
 954
 955       Search.Value := new Search_Data;
 956
 957       begin
 958          --  Check the pattern
 959
 960          Search.Value.Pattern := Compile (Pattern, Glob => True);
 961
 962       exception
 963          when Error_In_Regexp =>
 964             Free (Search.Value);
 965             raise Name_Error;
 966       end;
 967
 968       --  Initialize some Search components
 969
 970       Search.Value.Filter := Filter;
 971       Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
 972       Open (Search.Value.Dir, Directory);
 973       Search.Value.Is_Valid := True;
 974    end Start_Search;
 975
 976    ----------------------------------
 977    -- To_Lower_If_Case_Insensitive --
 978    ----------------------------------
 979
 980    procedure To_Lower_If_Case_Insensitive (S : in out String) is
 981    begin
 982       if not Is_Path_Name_Case_Sensitive then
 983          for J in S'Range loop
 984             S (J) := To_Lower (S (J));
 985          end loop;
 986       end if;
 987    end To_Lower_If_Case_Insensitive;
 988
 989 end Ada.Directories;