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