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