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-2007, 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.Calendar;               use Ada.Calendar;
  35 with Ada.Calendar.Formatting;    use Ada.Calendar.Formatting;
  36 with Ada.Directories.Validity;   use Ada.Directories.Validity;
  37 with Ada.Strings.Maps;
  38 with Ada.Strings.Fixed;
  39 with Ada.Strings.Unbounded;      use Ada.Strings.Unbounded;
  40 with Ada.Unchecked_Conversion;
  41 with Ada.Unchecked_Deallocation;
  42 with Ada.Characters.Handling;    use Ada.Characters.Handling;
  43
  44 with System.CRTL;                use System.CRTL;
  45 with System.OS_Lib;              use System.OS_Lib;
  46 with System.Regexp;              use System.Regexp;
  47
  48 with System;
  49
  50 package body Ada.Directories is
  51
  52    Filename_Max : constant Integer := 1024;
  53    --  1024 is the value of FILENAME_MAX in stdio.h
  54
  55    type Dir_Type_Value is new System.Address;
  56    --  This is the low-level address directory structure as returned by the C
  57    --  opendir routine.
  58
  59    No_Dir : constant Dir_Type_Value := Dir_Type_Value (System.Null_Address);
  60
  61    Dir_Separator : constant Character;
  62    pragma Import (C, Dir_Separator, "__gnat_dir_separator");
  63    --  Running system default directory separator
  64
  65    Dir_Seps : constant Ada.Strings.Maps.Character_Set :=
  66                 Ada.Strings.Maps.To_Set ("/\");
  67    --  UNIX and DOS style directory separators
  68
  69    Max_Path : Integer;
  70    pragma Import (C, Max_Path, "__gnat_max_path_len");
  71    --  The maximum length of a path
  72
  73    type Search_Data is record
  74       Is_Valid      : Boolean := False;
  75       Name          : Ada.Strings.Unbounded.Unbounded_String;
  76       Pattern       : Regexp;
  77       Filter        : Filter_Type;
  78       Dir           : Dir_Type_Value := No_Dir;
  79       Entry_Fetched : Boolean := False;
  80       Dir_Entry     : Directory_Entry_Type;
  81    end record;
  82    --  The current state of a search
  83
  84    Empty_String : constant String := (1 .. 0 => ASCII.NUL);
  85    --  Empty string, returned by function Extension when there is no extension
  86
  87    procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr);
  88
  89    procedure Close (Dir : Dir_Type_Value);
  90
  91    function File_Exists (Name : String) return Boolean;
  92    --  Returns True if the named file exists
  93
  94    procedure Fetch_Next_Entry (Search : Search_Type);
  95    --  Get the next entry in a directory, setting Entry_Fetched if successful
  96    --  or resetting Is_Valid if not.
  97
  98    procedure To_Lower_If_Case_Insensitive (S : in out String);
  99    --  Put S in lower case if file and path names are case-insensitive
 100
 101    ---------------
 102    -- Base_Name --
 103    ---------------
 104
 105    function Base_Name (Name : String) return String is
 106       Simple : String := Simple_Name (Name);
 107       --  Simple'First is guaranteed to be 1
 108
 109    begin
 110       To_Lower_If_Case_Insensitive (Simple);
 111
 112       --  Look for the last dot in the file name and return the part of the
 113       --  file name preceding this last dot. If the first dot is the first
 114       --  character of the file name, the base name is the empty string.
 115
 116       for Pos in reverse Simple'Range loop
 117          if Simple (Pos) = '.' then
 118             return Simple (1 .. Pos - 1);
 119          end if;
 120       end loop;
 121
 122       --  If there is no dot, return the complete file name
 123
 124       return Simple;
 125    end Base_Name;
 126
 127    -----------
 128    -- Close --
 129    -----------
 130
 131    procedure Close (Dir : Dir_Type_Value) is
 132       Discard : Integer;
 133       pragma Warnings (Off, Discard);
 134
 135       function closedir (directory : DIRs) return Integer;
 136       pragma Import (C, closedir, "__gnat_closedir");
 137
 138    begin
 139       Discard := closedir (DIRs (Dir));
 140    end Close;
 141
 142    -------------
 143    -- Compose --
 144    -------------
 145
 146    function Compose
 147      (Containing_Directory : String := "";
 148       Name                 : String;
 149       Extension            : String := "") return String
 150    is
 151       Result : String (1 .. Containing_Directory'Length +
 152                               Name'Length + Extension'Length + 2);
 153       Last   : Natural;
 154
 155    begin
 156       --  First, deal with the invalid cases
 157
 158       if not Is_Valid_Path_Name (Containing_Directory) then
 159          raise Name_Error;
 160
 161       elsif
 162         Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name))
 163       then
 164          raise Name_Error;
 165
 166       elsif Extension'Length /= 0
 167         and then not Is_Valid_Simple_Name (Name & '.' & Extension)
 168       then
 169          raise Name_Error;
 170
 171       --  This is not an invalid case so build the path name
 172
 173       else
 174          Last := Containing_Directory'Length;
 175          Result (1 .. Last) := Containing_Directory;
 176
 177          --  Add a directory separator if needed
 178
 179          if Result (Last) /= Dir_Separator then
 180             Last := Last + 1;
 181             Result (Last) := Dir_Separator;
 182          end if;
 183
 184          --  Add the file name
 185
 186          Result (Last + 1 .. Last + Name'Length) := Name;
 187          Last := Last + Name'Length;
 188
 189          --  If extension was specified, add dot followed by this extension
 190
 191          if Extension'Length /= 0 then
 192             Last := Last + 1;
 193             Result (Last) := '.';
 194             Result (Last + 1 .. Last + Extension'Length) := Extension;
 195             Last := Last + Extension'Length;
 196          end if;
 197
 198          To_Lower_If_Case_Insensitive (Result (1 .. Last));
 199          return Result (1 .. Last);
 200       end if;
 201    end Compose;
 202
 203    --------------------------
 204    -- Containing_Directory --
 205    --------------------------
 206
 207    function Containing_Directory (Name : String) return String is
 208    begin
 209       --  First, the invalid case
 210
 211       if not Is_Valid_Path_Name (Name) then
 212          raise Name_Error;
 213
 214       else
 215          declare
 216             Norm    : constant String := Normalize_Pathname (Name);
 217             Last_DS : constant Natural :=
 218                         Strings.Fixed.Index
 219                           (Name, Dir_Seps, Going => Strings.Backward);
 220
 221          begin
 222             if Last_DS = 0 then
 223
 224                --  There is no directory separator, returns current working
 225                --  directory.
 226
 227                return Current_Directory;
 228
 229             --  If Name indicates a root directory, raise Use_Error, because
 230             --  it has no containing directory.
 231
 232             elsif Norm = "/"
 233               or else
 234                 (Windows
 235                  and then
 236                    (Norm = "\"
 237                     or else
 238                       (Norm'Length = 3
 239                         and then Norm (Norm'Last - 1 .. Norm'Last) = ":\"
 240                         and then (Norm (Norm'First) in 'a' .. 'z'
 241                                    or else Norm (Norm'First) in 'A' .. 'Z'))))
 242             then
 243                raise Use_Error;
 244
 245             else
 246                declare
 247                   Last   : Positive := Last_DS - Name'First + 1;
 248                   Result : String (1 .. Last);
 249
 250                begin
 251                   Result := Name (Name'First .. Last_DS);
 252
 253                   --  Remove any trailing directory separator, except as the
 254                   --  first character or the first character following a drive
 255                   --  number on Windows.
 256
 257                   while Last > 1 loop
 258                      exit when
 259                        Result (Last) /= '/'
 260                          and then
 261                        Result (Last) /= Directory_Separator;
 262
 263                      exit when Windows
 264                        and then Last = 3
 265                        and then Result (2) = ':'
 266                        and then
 267                          (Result (1) in 'A' .. 'Z'
 268                            or else
 269                           Result (1) in 'a' .. 'z');
 270
 271                      Last := Last - 1;
 272                   end loop;
 273
 274                   --  Special case of current directory, identified by "."
 275
 276                   if Last = 1 and then Result (1) = '.' then
 277                      return Current_Directory;
 278
 279                   --  Special case of "..": the current directory may be a root
 280                   --  directory.
 281
 282                   elsif Last = 2 and then Result (1 .. 2) = ".." then
 283                      return Containing_Directory (Current_Directory);
 284
 285                   else
 286                      To_Lower_If_Case_Insensitive (Result (1 .. Last));
 287                      return Result (1 .. Last);
 288                   end if;
 289                end;
 290             end if;
 291          end;
 292       end if;
 293    end Containing_Directory;
 294
 295    ---------------
 296    -- Copy_File --
 297    ---------------
 298
 299    procedure Copy_File
 300      (Source_Name : String;
 301       Target_Name : String;
 302       Form        : String := "")
 303    is
 304       pragma Unreferenced (Form);
 305       Success : Boolean;
 306
 307    begin
 308       --  First, the invalid cases
 309
 310       if not Is_Valid_Path_Name (Source_Name)
 311         or else not Is_Valid_Path_Name (Target_Name)
 312         or else not Is_Regular_File (Source_Name)
 313       then
 314          raise Name_Error;
 315
 316       elsif Is_Directory (Target_Name) then
 317          raise Use_Error;
 318
 319       else
 320          --  The implementation uses System.OS_Lib.Copy_File, with parameters
 321          --  suitable for all platforms.
 322
 323          Copy_File (Source_Name, Target_Name, Success, Overwrite, None);
 324
 325          if not Success then
 326             raise Use_Error;
 327          end if;
 328       end if;
 329    end Copy_File;
 330
 331    ----------------------
 332    -- Create_Directory --
 333    ----------------------
 334
 335    procedure Create_Directory
 336      (New_Directory : String;
 337       Form          : String := "")
 338    is
 339       pragma Unreferenced (Form);
 340
 341       C_Dir_Name : constant String := New_Directory & ASCII.NUL;
 342
 343       function mkdir (Dir_Name : String) return Integer;
 344       pragma Import (C, mkdir, "__gnat_mkdir");
 345
 346    begin
 347       --  First, the invalid case
 348
 349       if not Is_Valid_Path_Name (New_Directory) then
 350          raise Name_Error;
 351
 352       else
 353          if mkdir (C_Dir_Name) /= 0 then
 354             raise Use_Error;
 355          end if;
 356       end if;
 357    end Create_Directory;
 358
 359    -----------------
 360    -- Create_Path --
 361    -----------------
 362
 363    procedure Create_Path
 364      (New_Directory : String;
 365       Form          : String := "")
 366    is
 367       pragma Unreferenced (Form);
 368
 369       New_Dir : String (1 .. New_Directory'Length + 1);
 370       Last    : Positive := 1;
 371
 372    begin
 373       --  First, the invalid case
 374
 375       if not Is_Valid_Path_Name (New_Directory) then
 376          raise Name_Error;
 377
 378       else
 379          --  Build New_Dir with a directory separator at the end, so that the
 380          --  complete path will be found in the loop below.
 381
 382          New_Dir (1 .. New_Directory'Length) := New_Directory;
 383          New_Dir (New_Dir'Last) := Directory_Separator;
 384
 385          --  Create, if necessary, each directory in the path
 386
 387          for J in 2 .. New_Dir'Last loop
 388
 389             --  Look for the end of an intermediate directory
 390
 391             if New_Dir (J) /= Dir_Separator then
 392                Last := J;
 393
 394             --  We have found a new intermediate directory each time we find
 395             --  a first directory separator.
 396
 397             elsif New_Dir (J - 1) /= Dir_Separator then
 398
 399                --  No need to create the directory if it already exists
 400
 401                if Is_Directory (New_Dir (1 .. Last)) then
 402                   null;
 403
 404                --  It is an error if a file with such a name already exists
 405
 406                elsif Is_Regular_File (New_Dir (1 .. Last)) then
 407                   raise Use_Error;
 408
 409                else
 410                   Create_Directory (New_Directory => New_Dir (1 .. Last));
 411                end if;
 412             end if;
 413          end loop;
 414       end if;
 415    end Create_Path;
 416
 417    -----------------------
 418    -- Current_Directory --
 419    -----------------------
 420
 421    function Current_Directory return String is
 422       Path_Len : Natural := Max_Path;
 423       Buffer   : String (1 .. 1 + Max_Path + 1);
 424
 425       procedure Local_Get_Current_Dir
 426         (Dir    : System.Address;
 427          Length : System.Address);
 428       pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
 429
 430    begin
 431       Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
 432
 433       declare
 434          Cur : String := Normalize_Pathname (Buffer (1 .. Path_Len));
 435
 436       begin
 437          To_Lower_If_Case_Insensitive (Cur);
 438
 439          if Cur'Length > 1 and then Cur (Cur'Last) = Dir_Separator then
 440             return Cur (1 .. Cur'Last - 1);
 441          else
 442             return Cur;
 443          end if;
 444       end;
 445    end Current_Directory;
 446
 447    ----------------------
 448    -- Delete_Directory --
 449    ----------------------
 450
 451    procedure Delete_Directory (Directory : String) is
 452    begin
 453       --  First, the invalid cases
 454
 455       if not Is_Valid_Path_Name (Directory) then
 456          raise Name_Error;
 457
 458       elsif not Is_Directory (Directory) then
 459          raise Name_Error;
 460
 461       else
 462          declare
 463             C_Dir_Name : constant String := Directory & ASCII.NUL;
 464          begin
 465             rmdir (C_Dir_Name);
 466
 467             if System.OS_Lib.Is_Directory (Directory) then
 468                raise Use_Error;
 469             end if;
 470          end;
 471       end if;
 472    end Delete_Directory;
 473
 474    -----------------
 475    -- Delete_File --
 476    -----------------
 477
 478    procedure Delete_File (Name : String) is
 479       Success : Boolean;
 480
 481    begin
 482       --  First, the invalid cases
 483
 484       if not Is_Valid_Path_Name (Name) then
 485          raise Name_Error;
 486
 487       elsif not Is_Regular_File (Name) then
 488          raise Name_Error;
 489
 490       else
 491          --  The implementation uses System.OS_Lib.Delete_File
 492
 493          Delete_File (Name, Success);
 494
 495          if not Success then
 496             raise Use_Error;
 497          end if;
 498       end if;
 499    end Delete_File;
 500
 501    -----------------
 502    -- Delete_Tree --
 503    -----------------
 504
 505    procedure Delete_Tree (Directory : String) is
 506       Current_Dir : constant String := Current_Directory;
 507       Search      : Search_Type;
 508       Dir_Ent     : Directory_Entry_Type;
 509    begin
 510       --  First, the invalid cases
 511
 512       if not Is_Valid_Path_Name (Directory) then
 513          raise Name_Error;
 514
 515       elsif not Is_Directory (Directory) then
 516          raise Name_Error;
 517
 518       else
 519          Set_Directory (Directory);
 520          Start_Search (Search, Directory => ".", Pattern => "");
 521
 522          while More_Entries (Search) loop
 523             Get_Next_Entry (Search, Dir_Ent);
 524
 525             declare
 526                File_Name : constant String := Simple_Name (Dir_Ent);
 527
 528             begin
 529                if System.OS_Lib.Is_Directory (File_Name) then
 530                   if File_Name /= "." and then File_Name /= ".." then
 531                      Delete_Tree (File_Name);
 532                   end if;
 533
 534                else
 535                   Delete_File (File_Name);
 536                end if;
 537             end;
 538          end loop;
 539
 540          Set_Directory (Current_Dir);
 541          End_Search (Search);
 542
 543          declare
 544             C_Dir_Name : constant String := Directory & ASCII.NUL;
 545
 546          begin
 547             rmdir (C_Dir_Name);
 548
 549             if System.OS_Lib.Is_Directory (Directory) then
 550                raise Use_Error;
 551             end if;
 552          end;
 553       end if;
 554    end Delete_Tree;
 555
 556    ------------
 557    -- Exists --
 558    ------------
 559
 560    function Exists (Name : String) return Boolean is
 561    begin
 562       --  First, the invalid case
 563
 564       if not Is_Valid_Path_Name (Name) then
 565          raise Name_Error;
 566
 567       else
 568          --  The implementation is in File_Exists
 569
 570          return File_Exists (Name);
 571       end if;
 572    end Exists;
 573
 574    ---------------
 575    -- Extension --
 576    ---------------
 577
 578    function Extension (Name : String) return String is
 579    begin
 580       --  First, the invalid case
 581
 582       if not Is_Valid_Path_Name (Name) then
 583          raise Name_Error;
 584
 585       else
 586          --  Look for first dot that is not followed by a directory separator
 587
 588          for Pos in reverse Name'Range loop
 589
 590             --  If a directory separator is found before a dot, there is no
 591             --  extension.
 592
 593             if Name (Pos) = Dir_Separator then
 594                return Empty_String;
 595
 596             elsif Name (Pos) = '.' then
 597
 598                --  We found a dot, build the return value with lower bound 1
 599
 600                declare
 601                   subtype Result_Type is String (1 .. Name'Last - Pos);
 602                begin
 603                   return Result_Type (Name (Pos + 1 .. Name'Last));
 604                end;
 605             end if;
 606          end loop;
 607
 608          --  No dot were found, there is no extension
 609
 610          return Empty_String;
 611       end if;
 612    end Extension;
 613
 614    ----------------------
 615    -- Fetch_Next_Entry --
 616    ----------------------
 617
 618    procedure Fetch_Next_Entry (Search : Search_Type) is
 619       Name : String (1 .. 255);
 620       Last : Natural;
 621
 622       Kind : File_Kind := Ordinary_File;
 623       --  Initialized to avoid a compilation warning
 624
 625       Filename_Addr : System.Address;
 626       Filename_Len  : aliased Integer;
 627
 628       Buffer : array (0 .. Filename_Max + 12) of Character;
 629       --  12 is the size of the dirent structure (see dirent.h), without the
 630       --  field for the filename.
 631
 632       function readdir_gnat
 633         (Directory : System.Address;
 634          Buffer    : System.Address;
 635          Last      : not null access Integer) return System.Address;
 636       pragma Import (C, readdir_gnat, "__gnat_readdir");
 637
 638       use System;
 639
 640    begin
 641       --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
 642
 643       loop
 644          Filename_Addr :=
 645            readdir_gnat
 646              (System.Address (Search.Value.Dir),
 647               Buffer'Address,
 648               Filename_Len'Access);
 649
 650          --  If no matching entry is found, set Is_Valid to False
 651
 652          if Filename_Addr = System.Null_Address then
 653             Search.Value.Is_Valid := False;
 654             exit;
 655          end if;
 656
 657          declare
 658             subtype Path_String is String (1 .. Filename_Len);
 659             type    Path_String_Access is access Path_String;
 660
 661             function Address_To_Access is new
 662               Ada.Unchecked_Conversion
 663                 (Source => Address,
 664                  Target => Path_String_Access);
 665
 666             Path_Access : constant Path_String_Access :=
 667                             Address_To_Access (Filename_Addr);
 668
 669          begin
 670             Last := Filename_Len;
 671             Name (1 .. Last) := Path_Access.all;
 672          end;
 673
 674          --  Check if the entry matches the pattern
 675
 676          if Match (Name (1 .. Last), Search.Value.Pattern) then
 677             declare
 678                Full_Name : constant String :=
 679                              Compose
 680                                (To_String
 681                                   (Search.Value.Name), Name (1 .. Last));
 682                Found     : Boolean := False;
 683
 684             begin
 685                if File_Exists (Full_Name) then
 686
 687                   --  Now check if the file kind matches the filter
 688
 689                   if Is_Regular_File (Full_Name) then
 690                      if Search.Value.Filter (Ordinary_File) then
 691                         Kind := Ordinary_File;
 692                         Found := True;
 693                      end if;
 694
 695                   elsif Is_Directory (Full_Name) then
 696                      if Search.Value.Filter (Directory) then
 697                         Kind := Directory;
 698                         Found := True;
 699                      end if;
 700
 701                   elsif Search.Value.Filter (Special_File) then
 702                      Kind := Special_File;
 703                      Found := True;
 704                   end if;
 705
 706                   --  If it does, update Search and return
 707
 708                   if Found then
 709                      Search.Value.Entry_Fetched := True;
 710                      Search.Value.Dir_Entry :=
 711                        (Is_Valid => True,
 712                         Simple   => To_Unbounded_String (Name (1 .. Last)),
 713                         Full     => To_Unbounded_String (Full_Name),
 714                         Kind     => Kind);
 715                      exit;
 716                   end if;
 717                end if;
 718             end;
 719          end if;
 720       end loop;
 721    end Fetch_Next_Entry;
 722
 723    -----------------
 724    -- File_Exists --
 725    -----------------
 726
 727    function File_Exists (Name : String) return Boolean is
 728       function C_File_Exists (A : System.Address) return Integer;
 729       pragma Import (C, C_File_Exists, "__gnat_file_exists");
 730
 731       C_Name : String (1 .. Name'Length + 1);
 732
 733    begin
 734       C_Name (1 .. Name'Length) := Name;
 735       C_Name (C_Name'Last) := ASCII.NUL;
 736       return C_File_Exists (C_Name (1)'Address) = 1;
 737    end File_Exists;
 738
 739    --------------
 740    -- Finalize --
 741    --------------
 742
 743    procedure Finalize (Search : in out Search_Type) is
 744    begin
 745       if Search.Value /= null then
 746
 747          --  Close the directory, if one is open
 748
 749          if Search.Value.Dir /= No_Dir then
 750             Close (Search.Value.Dir);
 751          end if;
 752
 753          Free (Search.Value);
 754       end if;
 755    end Finalize;
 756
 757    ---------------
 758    -- Full_Name --
 759    ---------------
 760
 761    function Full_Name (Name : String) return String is
 762    begin
 763       --  First, the invalid case
 764
 765       if not Is_Valid_Path_Name (Name) then
 766          raise Name_Error;
 767
 768       else
 769          --  Build the return value with lower bound 1
 770
 771          --  Use System.OS_Lib.Normalize_Pathname
 772
 773          declare
 774             Value : String := Normalize_Pathname (Name);
 775             subtype Result is String (1 .. Value'Length);
 776          begin
 777             To_Lower_If_Case_Insensitive (Value);
 778             return Result (Value);
 779          end;
 780       end if;
 781    end Full_Name;
 782
 783    function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
 784    begin
 785       --  First, the invalid case
 786
 787       if not Directory_Entry.Is_Valid then
 788          raise Status_Error;
 789
 790       else
 791          --  The value to return has already been computed
 792
 793          return To_String (Directory_Entry.Full);
 794       end if;
 795    end Full_Name;
 796
 797    --------------------
 798    -- Get_Next_Entry --
 799    --------------------
 800
 801    procedure Get_Next_Entry
 802      (Search          : in out Search_Type;
 803       Directory_Entry : out Directory_Entry_Type)
 804    is
 805    begin
 806       --  First, the invalid case
 807
 808       if Search.Value = null or else not Search.Value.Is_Valid then
 809          raise Status_Error;
 810       end if;
 811
 812       --  Fetch the next entry, if needed
 813
 814       if not Search.Value.Entry_Fetched then
 815          Fetch_Next_Entry (Search);
 816       end if;
 817
 818       --  It is an error if no valid entry is found
 819
 820       if not Search.Value.Is_Valid then
 821          raise Status_Error;
 822
 823       else
 824          --  Reset Entry_Fatched and return the entry
 825
 826          Search.Value.Entry_Fetched := False;
 827          Directory_Entry := Search.Value.Dir_Entry;
 828       end if;
 829    end Get_Next_Entry;
 830
 831    ----------
 832    -- Kind --
 833    ----------
 834
 835    function Kind (Name : String) return File_Kind is
 836    begin
 837       --  First, the invalid case
 838
 839       if not File_Exists (Name) then
 840          raise Name_Error;
 841
 842       elsif Is_Regular_File (Name) then
 843          return Ordinary_File;
 844
 845       elsif Is_Directory (Name) then
 846          return Directory;
 847
 848       else
 849          return Special_File;
 850       end if;
 851    end Kind;
 852
 853    function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
 854    begin
 855       --  First, the invalid case
 856
 857       if not Directory_Entry.Is_Valid then
 858          raise Status_Error;
 859
 860       else
 861          --  The value to return has already be computed
 862
 863          return Directory_Entry.Kind;
 864       end if;
 865    end Kind;
 866
 867    -----------------------
 868    -- Modification_Time --
 869    -----------------------
 870
 871    function Modification_Time (Name : String) return Time is
 872       Date   : OS_Time;
 873       Year   : Year_Type;
 874       Month  : Month_Type;
 875       Day    : Day_Type;
 876       Hour   : Hour_Type;
 877       Minute : Minute_Type;
 878       Second : Second_Type;
 879       Result : Time;
 880
 881    begin
 882       --  First, the invalid cases
 883
 884       if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
 885          raise Name_Error;
 886
 887       else
 888          Date := File_Time_Stamp (Name);
 889
 890          --  Break down the time stamp into its constituents relative to GMT.
 891          --  This version of Split does not recognize leap seconds or buffer
 892          --  space for time zone processing.
 893
 894          GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
 895
 896          --  On OpenVMS, the resulting time value must be in the local time
 897          --  zone. Ada.Calendar.Time_Of is exactly what we need. Note that
 898          --  in both cases, the sub seconds are set to zero (0.0) because the
 899          --  time stamp does not store them in its value.
 900
 901          if OpenVMS then
 902             Result :=
 903               Ada.Calendar.Time_Of
 904                 (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0));
 905
 906          --  On Unix and Windows, the result must be in GMT. Ada.Calendar.
 907          --  Formatting.Time_Of with default time zone of zero (0) is the
 908          --  routine of choice.
 909
 910          else
 911             Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
 912          end if;
 913
 914          return Result;
 915       end if;
 916    end Modification_Time;
 917
 918    function Modification_Time
 919      (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
 920    is
 921    begin
 922       --  First, the invalid case
 923
 924       if not Directory_Entry.Is_Valid then
 925          raise Status_Error;
 926
 927       else
 928          --  The value to return has already be computed
 929
 930          return Modification_Time (To_String (Directory_Entry.Full));
 931       end if;
 932    end Modification_Time;
 933
 934    ------------------
 935    -- More_Entries --
 936    ------------------
 937
 938    function More_Entries (Search : Search_Type) return Boolean is
 939    begin
 940       if Search.Value = null then
 941          return False;
 942
 943       elsif Search.Value.Is_Valid then
 944
 945          --  Fetch the next entry, if needed
 946
 947          if not Search.Value.Entry_Fetched then
 948             Fetch_Next_Entry (Search);
 949          end if;
 950       end if;
 951
 952       return Search.Value.Is_Valid;
 953    end More_Entries;
 954
 955    ------------
 956    -- Rename --
 957    ------------
 958
 959    procedure Rename (Old_Name, New_Name : String) is
 960       Success : Boolean;
 961
 962    begin
 963       --  First, the invalid cases
 964
 965       if not Is_Valid_Path_Name (Old_Name)
 966         or else not Is_Valid_Path_Name (New_Name)
 967         or else (not Is_Regular_File (Old_Name)
 968                    and then not Is_Directory (Old_Name))
 969       then
 970          raise Name_Error;
 971
 972       elsif Is_Regular_File (New_Name) or Is_Directory (New_Name) then
 973          raise Use_Error;
 974
 975       else
 976          --  The implementation uses System.OS_Lib.Rename_File
 977
 978          Rename_File (Old_Name, New_Name, Success);
 979
 980          if not Success then
 981             raise Use_Error;
 982          end if;
 983       end if;
 984    end Rename;
 985
 986    ------------
 987    -- Search --
 988    ------------
 989
 990    procedure Search
 991      (Directory : String;
 992       Pattern   : String;
 993       Filter    : Filter_Type := (others => True);
 994       Process   : not null access procedure
 995                                     (Directory_Entry : Directory_Entry_Type))
 996    is
 997       Srch            : Search_Type;
 998       Directory_Entry : Directory_Entry_Type;
 999
1000    begin
1001       Start_Search (Srch, Directory, Pattern, Filter);
1002
1003       while More_Entries (Srch) loop
1004          Get_Next_Entry (Srch, Directory_Entry);
1005          Process (Directory_Entry);
1006       end loop;
1007
1008       End_Search (Srch);
1009    end Search;
1010
1011    -------------------
1012    -- Set_Directory --
1013    -------------------
1014
1015    procedure Set_Directory (Directory : String) is
1016       C_Dir_Name : constant String := Directory & ASCII.NUL;
1017
1018       function chdir (Dir_Name : String) return Integer;
1019       pragma Import (C, chdir, "chdir");
1020
1021    begin
1022       if chdir (C_Dir_Name) /= 0 then
1023          raise Name_Error;
1024       end if;
1025    end Set_Directory;
1026
1027    -----------------
1028    -- Simple_Name --
1029    -----------------
1030
1031    function Simple_Name (Name : String) return String is
1032
1033       function Simple_Name_CI (Path : String) return String;
1034       --  This function does the job. The difference between Simple_Name_CI
1035       --  and Simple_Name (the parent function) is that the former is case
1036       --  sensitive, while the latter is not. Path and Suffix are adjusted
1037       --  appropriately before calling Simple_Name_CI under platforms where
1038       --  the file system is not case sensitive.
1039
1040       --------------------
1041       -- Simple_Name_CI --
1042       --------------------
1043
1044       function Simple_Name_CI (Path : String) return String is
1045          Cut_Start : Natural :=
1046                        Strings.Fixed.Index
1047                          (Path, Dir_Seps, Going => Strings.Backward);
1048          Cut_End   : Natural;
1049
1050       begin
1051          --  Cut_Start point to the first simple name character
1052
1053          if Cut_Start = 0 then
1054             Cut_Start := Path'First;
1055
1056          else
1057             Cut_Start := Cut_Start + 1;
1058          end if;
1059
1060          --  Cut_End point to the last simple name character
1061
1062          Cut_End := Path'Last;
1063
1064          Check_For_Standard_Dirs : declare
1065             Offset : constant Integer := Path'First - Name'First;
1066             BN     : constant String  :=
1067                        Name (Cut_Start - Offset .. Cut_End - Offset);
1068             --  Here we use Simple_Name.Name to keep the original casing
1069
1070             Has_Drive_Letter : constant Boolean :=
1071                                  System.OS_Lib.Path_Separator /= ':';
1072             --  If Path separator is not ':' then we are on a DOS based OS
1073             --  where this character is used as a drive letter separator.
1074
1075          begin
1076             if BN = "." or else BN = ".." then
1077                return "";
1078
1079             elsif Has_Drive_Letter
1080               and then BN'Length > 2
1081               and then Characters.Handling.Is_Letter (BN (BN'First))
1082               and then BN (BN'First + 1) = ':'
1083             then
1084                --  We have a DOS drive letter prefix, remove it
1085
1086                return BN (BN'First + 2 .. BN'Last);
1087
1088             else
1089                return BN;
1090             end if;
1091          end Check_For_Standard_Dirs;
1092       end Simple_Name_CI;
1093
1094    --  Start of processing for Simple_Name
1095
1096    begin
1097       --  First, the invalid case
1098
1099       if not Is_Valid_Path_Name (Name) then
1100          raise Name_Error;
1101
1102       else
1103          --  Build the value to return with lower bound 1
1104
1105          if Is_Path_Name_Case_Sensitive then
1106             declare
1107                Value : constant String := Simple_Name_CI (Name);
1108                subtype Result is String (1 .. Value'Length);
1109             begin
1110                return Result (Value);
1111             end;
1112
1113          else
1114             declare
1115                Value : constant String :=
1116                          Simple_Name_CI (Characters.Handling.To_Lower (Name));
1117                subtype Result is String (1 .. Value'Length);
1118             begin
1119                return Result (Value);
1120             end;
1121          end if;
1122       end if;
1123    end Simple_Name;
1124
1125    function Simple_Name
1126      (Directory_Entry : Directory_Entry_Type) return String
1127    is
1128    begin
1129       --  First, the invalid case
1130
1131       if not Directory_Entry.Is_Valid then
1132          raise Status_Error;
1133
1134       else
1135          --  The value to return has already be computed
1136
1137          return To_String (Directory_Entry.Simple);
1138       end if;
1139    end Simple_Name;
1140
1141    ----------
1142    -- Size --
1143    ----------
1144
1145    function Size (Name : String) return File_Size is
1146       C_Name : String (1 .. Name'Length + 1);
1147
1148       function C_Size (Name : System.Address) return Long_Integer;
1149       pragma Import (C, C_Size, "__gnat_named_file_length");
1150
1151    begin
1152       --  First, the invalid case
1153
1154       if not Is_Regular_File (Name) then
1155          raise Name_Error;
1156
1157       else
1158          C_Name (1 .. Name'Length) := Name;
1159          C_Name (C_Name'Last) := ASCII.NUL;
1160          return File_Size (C_Size (C_Name'Address));
1161       end if;
1162    end Size;
1163
1164    function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1165    begin
1166       --  First, the invalid case
1167
1168       if not Directory_Entry.Is_Valid then
1169          raise Status_Error;
1170
1171       else
1172          --  The value to return has already be computed
1173
1174          return Size (To_String (Directory_Entry.Full));
1175       end if;
1176    end Size;
1177
1178    ------------------
1179    -- Start_Search --
1180    ------------------
1181
1182    procedure Start_Search
1183      (Search    : in out Search_Type;
1184       Directory : String;
1185       Pattern   : String;
1186       Filter    : Filter_Type := (others => True))
1187    is
1188       function opendir (file_name : String) return DIRs;
1189       pragma Import (C, opendir, "__gnat_opendir");
1190
1191       C_File_Name : constant String := Directory & ASCII.NUL;
1192
1193    begin
1194       --  First, the invalid case
1195
1196       if not Is_Directory (Directory) then
1197          raise Name_Error;
1198       end if;
1199
1200       --  If needed, finalize Search
1201
1202       Finalize (Search);
1203
1204       --  Allocate the default data
1205
1206       Search.Value := new Search_Data;
1207
1208       begin
1209          --  Check the pattern
1210
1211          Search.Value.Pattern := Compile (Pattern, Glob => True);
1212
1213       exception
1214          when Error_In_Regexp =>
1215             Free (Search.Value);
1216             raise Name_Error;
1217       end;
1218
1219       --  Initialize some Search components
1220
1221       Search.Value.Filter := Filter;
1222       Search.Value.Name := To_Unbounded_String (Full_Name (Directory));
1223       Search.Value.Dir := Dir_Type_Value (opendir (C_File_Name));
1224       Search.Value.Is_Valid := True;
1225    end Start_Search;
1226
1227    ----------------------------------
1228    -- To_Lower_If_Case_Insensitive --
1229    ----------------------------------
1230
1231    procedure To_Lower_If_Case_Insensitive (S : in out String) is
1232    begin
1233       if not Is_Path_Name_Case_Sensitive then
1234          for J in S'Range loop
1235             S (J) := To_Lower (S (J));
1236          end loop;
1237       end if;
1238    end To_Lower_If_Case_Insensitive;
1239
1240 end Ada.Directories;