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