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