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