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