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