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