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