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-2016, 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       --  We need to resolve links because of RM A.16(47), which requires
 532       --  that we not return alternative names for files.
 533
 534       return Normalize_Pathname (Buffer (1 .. Path_Len));
 535    end Current_Directory;
 536
 537    ----------------------
 538    -- Delete_Directory --
 539    ----------------------
 540
 541    procedure Delete_Directory (Directory : String) is
 542    begin
 543       --  First, the invalid cases
 544
 545       if not Is_Valid_Path_Name (Directory) then
 546          raise Name_Error with
 547            "invalid directory path name """ & Directory & '"';
 548
 549       elsif not Is_Directory (Directory) then
 550          raise Name_Error with '"' & Directory & """ not a directory";
 551
 552       --  Do the deletion, checking for error
 553
 554       else
 555          declare
 556             C_Dir_Name : constant String := Directory & ASCII.NUL;
 557          begin
 558             if rmdir (C_Dir_Name) /= 0 then
 559                raise Use_Error with
 560                  "deletion of directory """ & Directory & """ failed";
 561             end if;
 562          end;
 563       end if;
 564    end Delete_Directory;
 565
 566    -----------------
 567    -- Delete_File --
 568    -----------------
 569
 570    procedure Delete_File (Name : String) is
 571       Success : Boolean;
 572
 573    begin
 574       --  First, the invalid cases
 575
 576       if not Is_Valid_Path_Name (Name) then
 577          raise Name_Error with "invalid path name """ & Name & '"';
 578
 579       elsif not Is_Regular_File (Name)
 580         and then not Is_Symbolic_Link (Name)
 581       then
 582          raise Name_Error with "file """ & Name & """ does not exist";
 583
 584       else
 585          --  Do actual deletion using System.OS_Lib.Delete_File
 586
 587          Delete_File (Name, Success);
 588
 589          if not Success then
 590             raise Use_Error with "file """ & Name & """ could not be deleted";
 591          end if;
 592       end if;
 593    end Delete_File;
 594
 595    -----------------
 596    -- Delete_Tree --
 597    -----------------
 598
 599    procedure Delete_Tree (Directory : String) is
 600       Search      : Search_Type;
 601       Dir_Ent     : Directory_Entry_Type;
 602    begin
 603       --  First, the invalid cases
 604
 605       if not Is_Valid_Path_Name (Directory) then
 606          raise Name_Error with
 607            "invalid directory path name """ & Directory & '"';
 608
 609       elsif not Is_Directory (Directory) then
 610          raise Name_Error with '"' & Directory & """ not a directory";
 611
 612       else
 613
 614          --  We used to change the current directory to Directory here,
 615          --  allowing the use of a local Simple_Name for all references. This
 616          --  turned out unfriendly to multitasking programs, where tasks
 617          --  running in parallel of this Delete_Tree could see their current
 618          --  directory change unpredictably. We now resort to Full_Name
 619          --  computations to reach files and subdirs instead.
 620
 621          Start_Search (Search, Directory => Directory, Pattern => "");
 622          while More_Entries (Search) loop
 623             Get_Next_Entry (Search, Dir_Ent);
 624
 625             declare
 626                Fname : constant String := Full_Name   (Dir_Ent);
 627                Sname : constant String := Simple_Name (Dir_Ent);
 628
 629             begin
 630                if OS_Lib.Is_Directory (Fname) then
 631                   if Sname /= "." and then Sname /= ".." then
 632                      Delete_Tree (Fname);
 633                   end if;
 634                else
 635                   Delete_File (Fname);
 636                end if;
 637             end;
 638          end loop;
 639
 640          End_Search (Search);
 641
 642          declare
 643             C_Dir_Name : constant String := Directory & ASCII.NUL;
 644
 645          begin
 646             if rmdir (C_Dir_Name) /= 0 then
 647                raise Use_Error with
 648                  "directory tree rooted at """ &
 649                    Directory & """ could not be deleted";
 650             end if;
 651          end;
 652       end if;
 653    end Delete_Tree;
 654
 655    ------------
 656    -- Exists --
 657    ------------
 658
 659    function Exists (Name : String) return Boolean is
 660    begin
 661       --  First, the invalid case
 662
 663       if not Is_Valid_Path_Name (Name) then
 664          raise Name_Error with "invalid path name """ & Name & '"';
 665
 666       else
 667          --  The implementation is in File_Exists
 668
 669          return File_Exists (Name);
 670       end if;
 671    end Exists;
 672
 673    ---------------
 674    -- Extension --
 675    ---------------
 676
 677    function Extension (Name : String) return String is
 678    begin
 679       --  First, the invalid case
 680
 681       if not Is_Valid_Path_Name (Name) then
 682          raise Name_Error with "invalid path name """ & Name & '"';
 683
 684       else
 685          --  Look for first dot that is not followed by a directory separator
 686
 687          for Pos in reverse Name'Range loop
 688
 689             --  If a directory separator is found before a dot, there is no
 690             --  extension.
 691
 692             if Is_In (Name (Pos), Dir_Seps) then
 693                return Empty_String;
 694
 695             elsif Name (Pos) = '.' then
 696
 697                --  We found a dot, build the return value with lower bound 1
 698
 699                declare
 700                   subtype Result_Type is String (1 .. Name'Last - Pos);
 701                begin
 702                   return Result_Type (Name (Pos + 1 .. Name'Last));
 703                end;
 704             end if;
 705          end loop;
 706
 707          --  No dot were found, there is no extension
 708
 709          return Empty_String;
 710       end if;
 711    end Extension;
 712
 713    ----------------------
 714    -- Fetch_Next_Entry --
 715    ----------------------
 716
 717    procedure Fetch_Next_Entry (Search : Search_Type) is
 718       Name : String (1 .. NAME_MAX);
 719       Last : Natural;
 720
 721       Kind : File_Kind := Ordinary_File;
 722       --  Initialized to avoid a compilation warning
 723
 724       Filename_Addr : Address;
 725       Filename_Len  : aliased Integer;
 726
 727       Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character;
 728
 729       function readdir_gnat
 730         (Directory : Address;
 731          Buffer    : Address;
 732          Last      : not null access Integer) return Address;
 733       pragma Import (C, readdir_gnat, "__gnat_readdir");
 734
 735    begin
 736       --  Search.Value.Is_Valid is always True when Fetch_Next_Entry is called
 737
 738       loop
 739          Filename_Addr :=
 740            readdir_gnat
 741              (Address (Search.Value.Dir),
 742               Buffer'Address,
 743               Filename_Len'Access);
 744
 745          --  If no matching entry is found, set Is_Valid to False
 746
 747          if Filename_Addr = Null_Address then
 748             Search.Value.Is_Valid := False;
 749             exit;
 750          end if;
 751
 752          if Filename_Len > Name'Length then
 753             raise Use_Error with "file name too long";
 754          end if;
 755
 756          declare
 757             subtype Name_String is String (1 .. Filename_Len);
 758             Dent_Name : Name_String;
 759             for Dent_Name'Address use Filename_Addr;
 760             pragma Import (Ada, Dent_Name);
 761
 762          begin
 763             Last := Filename_Len;
 764             Name (1 .. Last) := Dent_Name;
 765          end;
 766
 767          --  Check if the entry matches the pattern
 768
 769          if Match (Name (1 .. Last), Search.Value.Pattern) then
 770             declare
 771                C_Full_Name : constant String :=
 772                                Compose (To_String (Search.Value.Name),
 773                                         Name (1 .. Last)) & ASCII.NUL;
 774                Full_Name   : String renames
 775                                C_Full_Name
 776                                  (C_Full_Name'First .. C_Full_Name'Last - 1);
 777                Found       : Boolean := False;
 778                Attr        : aliased File_Attributes;
 779                Exists      : Integer;
 780                Error       : Integer;
 781
 782             begin
 783                Reset_Attributes (Attr'Access);
 784                Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access);
 785                Error  := Error_Attributes (Attr'Access);
 786
 787                if Error /= 0 then
 788                   raise Use_Error
 789                     with Full_Name & ": " & Errno_Message (Err => Error);
 790                end if;
 791
 792                if Exists = 1 then
 793
 794                   --  Now check if the file kind matches the filter
 795
 796                   if Is_Regular_File_Attr
 797                        (C_Full_Name'Address, Attr'Access) = 1
 798                   then
 799                      if Search.Value.Filter (Ordinary_File) then
 800                         Kind := Ordinary_File;
 801                         Found := True;
 802                      end if;
 803
 804                   elsif Is_Directory_Attr
 805                           (C_Full_Name'Address, Attr'Access) = 1
 806                   then
 807                      if Search.Value.Filter (Directory) then
 808                         Kind := Directory;
 809                         Found := True;
 810                      end if;
 811
 812                   elsif Search.Value.Filter (Special_File) then
 813                      Kind := Special_File;
 814                      Found := True;
 815                   end if;
 816
 817                   --  If it does, update Search and return
 818
 819                   if Found then
 820                      Search.Value.Entry_Fetched := True;
 821                      Search.Value.Dir_Entry :=
 822                        (Is_Valid => True,
 823                         Simple   => To_Unbounded_String (Name (1 .. Last)),
 824                         Full     => To_Unbounded_String (Full_Name),
 825                         Kind     => Kind);
 826                      exit;
 827                   end if;
 828                end if;
 829             end;
 830          end if;
 831       end loop;
 832    end Fetch_Next_Entry;
 833
 834    -----------------
 835    -- File_Exists --
 836    -----------------
 837
 838    function File_Exists (Name : String) return Boolean is
 839       function C_File_Exists (A : Address) return Integer;
 840       pragma Import (C, C_File_Exists, "__gnat_file_exists");
 841
 842       C_Name : String (1 .. Name'Length + 1);
 843
 844    begin
 845       C_Name (1 .. Name'Length) := Name;
 846       C_Name (C_Name'Last) := ASCII.NUL;
 847       return C_File_Exists (C_Name'Address) = 1;
 848    end File_Exists;
 849
 850    --------------
 851    -- Finalize --
 852    --------------
 853
 854    procedure Finalize (Search : in out Search_Type) is
 855    begin
 856       if Search.Value /= null then
 857
 858          --  Close the directory, if one is open
 859
 860          if Search.Value.Dir /= No_Dir then
 861             Close (Search.Value.Dir);
 862          end if;
 863
 864          Free (Search.Value);
 865       end if;
 866    end Finalize;
 867
 868    ---------------
 869    -- Full_Name --
 870    ---------------
 871
 872    function Full_Name (Name : String) return String is
 873    begin
 874       --  First, the invalid case
 875
 876       if not Is_Valid_Path_Name (Name) then
 877          raise Name_Error with "invalid path name """ & Name & '"';
 878
 879       else
 880          --  Build the return value with lower bound 1
 881
 882          --  Use System.OS_Lib.Normalize_Pathname
 883
 884          declare
 885             --  We need to resolve links because of (RM A.16(47)), which says
 886             --  we must not return alternative names for files.
 887
 888             Value : constant String := Normalize_Pathname (Name);
 889             subtype Result is String (1 .. Value'Length);
 890
 891          begin
 892             return Result (Value);
 893          end;
 894       end if;
 895    end Full_Name;
 896
 897    function Full_Name (Directory_Entry : Directory_Entry_Type) return String is
 898    begin
 899       --  First, the invalid case
 900
 901       if not Directory_Entry.Is_Valid then
 902          raise Status_Error with "invalid directory entry";
 903
 904       else
 905          --  The value to return has already been computed
 906
 907          return To_String (Directory_Entry.Full);
 908       end if;
 909    end Full_Name;
 910
 911    --------------------
 912    -- Get_Next_Entry --
 913    --------------------
 914
 915    procedure Get_Next_Entry
 916      (Search          : in out Search_Type;
 917       Directory_Entry : out Directory_Entry_Type)
 918    is
 919    begin
 920       --  First, the invalid case
 921
 922       if Search.Value = null or else not Search.Value.Is_Valid then
 923          raise Status_Error with "invalid search";
 924       end if;
 925
 926       --  Fetch the next entry, if needed
 927
 928       if not Search.Value.Entry_Fetched then
 929          Fetch_Next_Entry (Search);
 930       end if;
 931
 932       --  It is an error if no valid entry is found
 933
 934       if not Search.Value.Is_Valid then
 935          raise Status_Error with "no next entry";
 936
 937       else
 938          --  Reset Entry_Fetched and return the entry
 939
 940          Search.Value.Entry_Fetched := False;
 941          Directory_Entry := Search.Value.Dir_Entry;
 942       end if;
 943    end Get_Next_Entry;
 944
 945    ----------
 946    -- Kind --
 947    ----------
 948
 949    function Kind (Name : String) return File_Kind is
 950    begin
 951       --  First, the invalid case
 952
 953       if not File_Exists (Name) then
 954          raise Name_Error with "file """ & Name & """ does not exist";
 955
 956       --  If OK, return appropriate kind
 957
 958       elsif Is_Regular_File (Name) then
 959          return Ordinary_File;
 960
 961       elsif Is_Directory (Name) then
 962          return Directory;
 963
 964       else
 965          return Special_File;
 966       end if;
 967    end Kind;
 968
 969    function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is
 970    begin
 971       --  First, the invalid case
 972
 973       if not Directory_Entry.Is_Valid then
 974          raise Status_Error with "invalid directory entry";
 975
 976       else
 977          --  The value to return has already be computed
 978
 979          return Directory_Entry.Kind;
 980       end if;
 981    end Kind;
 982
 983    -----------------------
 984    -- Modification_Time --
 985    -----------------------
 986
 987    function Modification_Time (Name : String) return Time is
 988       Date   : OS_Time;
 989       Year   : Year_Type;
 990       Month  : Month_Type;
 991       Day    : Day_Type;
 992       Hour   : Hour_Type;
 993       Minute : Minute_Type;
 994       Second : Second_Type;
 995
 996    begin
 997       --  First, the invalid cases
 998
 999       if not (Is_Regular_File (Name) or else Is_Directory (Name)) then
1000          raise Name_Error with '"' & Name & """ not a file or directory";
1001
1002       else
1003          Date := File_Time_Stamp (Name);
1004
1005          --  Break down the time stamp into its constituents relative to GMT.
1006          --  This version of Split does not recognize leap seconds or buffer
1007          --  space for time zone processing.
1008
1009          GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
1010
1011          --  The result must be in GMT. Ada.Calendar.
1012          --  Formatting.Time_Of with default time zone of zero (0) is the
1013          --  routine of choice.
1014
1015          return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
1016       end if;
1017    end Modification_Time;
1018
1019    function Modification_Time
1020      (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time
1021    is
1022    begin
1023       --  First, the invalid case
1024
1025       if not Directory_Entry.Is_Valid then
1026          raise Status_Error with "invalid directory entry";
1027
1028       else
1029          --  The value to return has already be computed
1030
1031          return Modification_Time (To_String (Directory_Entry.Full));
1032       end if;
1033    end Modification_Time;
1034
1035    ------------------
1036    -- More_Entries --
1037    ------------------
1038
1039    function More_Entries (Search : Search_Type) return Boolean is
1040    begin
1041       if Search.Value = null then
1042          return False;
1043
1044       elsif Search.Value.Is_Valid then
1045
1046          --  Fetch the next entry, if needed
1047
1048          if not Search.Value.Entry_Fetched then
1049             Fetch_Next_Entry (Search);
1050          end if;
1051       end if;
1052
1053       return Search.Value.Is_Valid;
1054    end More_Entries;
1055
1056    ------------
1057    -- Rename --
1058    ------------
1059
1060    procedure Rename (Old_Name, New_Name : String) is
1061       Success : Boolean;
1062
1063    begin
1064       --  First, the invalid cases
1065
1066       if not Is_Valid_Path_Name (Old_Name) then
1067          raise Name_Error with "invalid old path name """ & Old_Name & '"';
1068
1069       elsif not Is_Valid_Path_Name (New_Name) then
1070          raise Name_Error with "invalid new path name """ & New_Name & '"';
1071
1072       elsif not Is_Regular_File (Old_Name)
1073             and then not Is_Directory (Old_Name)
1074       then
1075          raise Name_Error with "old file """ & Old_Name & """ does not exist";
1076
1077       elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then
1078          raise Use_Error with
1079            "new name """ & New_Name
1080            & """ designates a file that already exists";
1081
1082       --  Do actual rename using System.OS_Lib.Rename_File
1083
1084       else
1085          Rename_File (Old_Name, New_Name, Success);
1086
1087          if not Success then
1088
1089             --  AI05-0231-1: Name_Error should be raised in case a directory
1090             --  component of New_Name does not exist (as in New_Name =>
1091             --  "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT
1092             --  also indicate that the Old_Name does not exist, but we already
1093             --  checked for that above. All other errors are Use_Error.
1094
1095             if Errno = ENOENT then
1096                raise Name_Error with
1097                  "file """ & Containing_Directory (New_Name) & """ not found";
1098
1099             else
1100                raise Use_Error with
1101                  "file """ & Old_Name & """ could not be renamed";
1102             end if;
1103          end if;
1104       end if;
1105    end Rename;
1106
1107    ------------
1108    -- Search --
1109    ------------
1110
1111    procedure Search
1112      (Directory : String;
1113       Pattern   : String;
1114       Filter    : Filter_Type := (others => True);
1115       Process   : not null access procedure
1116                                     (Directory_Entry : Directory_Entry_Type))
1117    is
1118       Srch            : Search_Type;
1119       Directory_Entry : Directory_Entry_Type;
1120
1121    begin
1122       Start_Search (Srch, Directory, Pattern, Filter);
1123       while More_Entries (Srch) loop
1124          Get_Next_Entry (Srch, Directory_Entry);
1125          Process (Directory_Entry);
1126       end loop;
1127
1128       End_Search (Srch);
1129    end Search;
1130
1131    -------------------
1132    -- Set_Directory --
1133    -------------------
1134
1135    procedure Set_Directory (Directory : String) is
1136       C_Dir_Name : constant String := Directory & ASCII.NUL;
1137    begin
1138       if not Is_Valid_Path_Name (Directory) then
1139          raise Name_Error with
1140            "invalid directory path name & """ & Directory & '"';
1141
1142       elsif not Is_Directory (Directory) then
1143          raise Name_Error with
1144            "directory """ & Directory & """ does not exist";
1145
1146       elsif chdir (C_Dir_Name) /= 0 then
1147          raise Name_Error with
1148            "could not set to designated directory """ & Directory & '"';
1149       end if;
1150    end Set_Directory;
1151
1152    -----------------
1153    -- Simple_Name --
1154    -----------------
1155
1156    function Simple_Name (Name : String) return String is
1157
1158       function Simple_Name_Internal (Path : String) return String;
1159       --  This function does the job
1160
1161       --------------------------
1162       -- Simple_Name_Internal --
1163       --------------------------
1164
1165       function Simple_Name_Internal (Path : String) return String is
1166          Cut_Start : Natural :=
1167            Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward);
1168          Cut_End   : Natural;
1169
1170       begin
1171          --  Cut_Start pointS to the first simple name character
1172
1173          Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
1174
1175          --  Cut_End point to the last simple name character
1176
1177          Cut_End := Path'Last;
1178
1179          Check_For_Standard_Dirs : declare
1180             BN : constant String := Path (Cut_Start .. Cut_End);
1181
1182             Has_Drive_Letter : constant Boolean :=
1183               OS_Lib.Path_Separator /= ':';
1184             --  If Path separator is not ':' then we are on a DOS based OS
1185             --  where this character is used as a drive letter separator.
1186
1187          begin
1188             if BN = "." or else BN = ".." then
1189                return "";
1190
1191             elsif Has_Drive_Letter
1192               and then BN'Length > 2
1193               and then Characters.Handling.Is_Letter (BN (BN'First))
1194               and then BN (BN'First + 1) = ':'
1195             then
1196                --  We have a DOS drive letter prefix, remove it
1197
1198                return BN (BN'First + 2 .. BN'Last);
1199
1200             else
1201                return BN;
1202             end if;
1203          end Check_For_Standard_Dirs;
1204       end Simple_Name_Internal;
1205
1206    --  Start of processing for Simple_Name
1207
1208    begin
1209       --  First, the invalid case
1210
1211       if not Is_Valid_Path_Name (Name) then
1212          raise Name_Error with "invalid path name """ & Name & '"';
1213
1214       else
1215          --  Build the value to return with lower bound 1
1216
1217          declare
1218             Value : constant String := Simple_Name_Internal (Name);
1219             subtype Result is String (1 .. Value'Length);
1220          begin
1221             return Result (Value);
1222          end;
1223       end if;
1224    end Simple_Name;
1225
1226    function Simple_Name
1227      (Directory_Entry : Directory_Entry_Type) return String is
1228    begin
1229       --  First, the invalid case
1230
1231       if not Directory_Entry.Is_Valid then
1232          raise Status_Error with "invalid directory entry";
1233
1234       else
1235          --  The value to return has already be computed
1236
1237          return To_String (Directory_Entry.Simple);
1238       end if;
1239    end Simple_Name;
1240
1241    ----------
1242    -- Size --
1243    ----------
1244
1245    function Size (Name : String) return File_Size is
1246       C_Name : String (1 .. Name'Length + 1);
1247
1248       function C_Size (Name : Address) return int64;
1249       pragma Import (C, C_Size, "__gnat_named_file_length");
1250
1251    begin
1252       --  First, the invalid case
1253
1254       if not Is_Regular_File (Name) then
1255          raise Name_Error with "file """ & Name & """ does not exist";
1256
1257       else
1258          C_Name (1 .. Name'Length) := Name;
1259          C_Name (C_Name'Last) := ASCII.NUL;
1260          return File_Size (C_Size (C_Name'Address));
1261       end if;
1262    end Size;
1263
1264    function Size (Directory_Entry : Directory_Entry_Type) return File_Size is
1265    begin
1266       --  First, the invalid case
1267
1268       if not Directory_Entry.Is_Valid then
1269          raise Status_Error with "invalid directory entry";
1270
1271       else
1272          --  The value to return has already be computed
1273
1274          return Size (To_String (Directory_Entry.Full));
1275       end if;
1276    end Size;
1277
1278    ------------------
1279    -- Start_Search --
1280    ------------------
1281
1282    procedure Start_Search
1283      (Search    : in out Search_Type;
1284       Directory : String;
1285       Pattern   : String;
1286       Filter    : Filter_Type := (others => True))
1287    is
1288       function opendir (file_name : String) return DIRs;
1289       pragma Import (C, opendir, "__gnat_opendir");
1290
1291       C_File_Name : constant String := Directory & ASCII.NUL;
1292       Pat         : Regexp;
1293       Dir         : Dir_Type_Value;
1294
1295    begin
1296       --  First, the invalid case Name_Error
1297
1298       if not Is_Directory (Directory) then
1299          raise Name_Error with
1300            "unknown directory """ & Simple_Name (Directory) & '"';
1301       end if;
1302
1303       --  Check the pattern
1304
1305       begin
1306          Pat := Compile
1307            (Pattern,
1308             Glob           => True,
1309             Case_Sensitive => Is_Path_Name_Case_Sensitive);
1310       exception
1311          when Error_In_Regexp =>
1312             Free (Search.Value);
1313             raise Name_Error with "invalid pattern """ & Pattern & '"';
1314       end;
1315
1316       Dir := Dir_Type_Value (opendir (C_File_Name));
1317
1318       if Dir = No_Dir then
1319          raise Use_Error with
1320            "unreadable directory """ & Simple_Name (Directory) & '"';
1321       end if;
1322
1323       --  If needed, finalize Search
1324
1325       Finalize (Search);
1326
1327       --  Allocate the default data
1328
1329       Search.Value := new Search_Data;
1330
1331       --  Initialize some Search components
1332
1333       Search.Value.Filter   := Filter;
1334       Search.Value.Name     := To_Unbounded_String (Full_Name (Directory));
1335       Search.Value.Pattern  := Pat;
1336       Search.Value.Dir      := Dir;
1337       Search.Value.Is_Valid := True;
1338    end Start_Search;
1339
1340 end Ada.Directories;