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