gcc/ada/g-dirope.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --            G N A T . D I R E C T O R Y _ O P E R A T I O N S             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 1998-2009, AdaCore                     --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Characters.Handling;
  35 with Ada.Strings.Fixed;
  36
  37 with Ada.Unchecked_Deallocation;
  38 with Ada.Unchecked_Conversion;
  39
  40 with System;      use System;
  41 with System.CRTL; use System.CRTL;
  42
  43 with GNAT.OS_Lib;
  44
  45 package body GNAT.Directory_Operations is
  46
  47    use Ada;
  48
  49    Filename_Max : constant Integer := 1024;
  50    --  1024 is the value of FILENAME_MAX in stdio.h
  51
  52    procedure Free is new
  53      Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
  54
  55    On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\';
  56    --  An indication that we are on Windows. Used in Get_Current_Dir, to
  57    --  deal with drive letters in the beginning of absolute paths.
  58
  59    ---------------
  60    -- Base_Name --
  61    ---------------
  62
  63    function Base_Name
  64      (Path   : Path_Name;
  65       Suffix : String := "") return String
  66    is
  67       function Get_File_Names_Case_Sensitive return Integer;
  68       pragma Import
  69         (C, Get_File_Names_Case_Sensitive,
  70          "__gnat_get_file_names_case_sensitive");
  71
  72       Case_Sensitive_File_Name : constant Boolean :=
  73                                    Get_File_Names_Case_Sensitive = 1;
  74
  75       function Basename
  76         (Path   : Path_Name;
  77          Suffix : String := "") return String;
  78       --  This function does the job. The only difference between Basename
  79       --  and Base_Name (the parent function) is that the former is case
  80       --  sensitive, while the latter is not. Path and Suffix are adjusted
  81       --  appropriately before calling Basename under platforms where the
  82       --  file system is not case sensitive.
  83
  84       --------------
  85       -- Basename --
  86       --------------
  87
  88       function Basename
  89         (Path   : Path_Name;
  90          Suffix : String    := "") return String
  91       is
  92          Cut_Start : Natural :=
  93                        Strings.Fixed.Index
  94                          (Path, Dir_Seps, Going => Strings.Backward);
  95          Cut_End : Natural;
  96
  97       begin
  98          --  Cut_Start point to the first basename character
  99
 100          Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1);
 101
 102          --  Cut_End point to the last basename character
 103
 104          Cut_End := Path'Last;
 105
 106          --  If basename ends with Suffix, adjust Cut_End
 107
 108          if Suffix /= ""
 109            and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix
 110          then
 111             Cut_End := Path'Last - Suffix'Length;
 112          end if;
 113
 114          Check_For_Standard_Dirs : declare
 115             Offset : constant Integer := Path'First - Base_Name.Path'First;
 116             BN     : constant String  :=
 117                        Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset);
 118             --  Here we use Base_Name.Path to keep the original casing
 119
 120             Has_Drive_Letter : constant Boolean :=
 121                                  OS_Lib.Path_Separator /= ':';
 122             --  If Path separator is not ':' then we are on a DOS based OS
 123             --  where this character is used as a drive letter separator.
 124
 125          begin
 126             if BN = "." or else BN = ".." then
 127                return "";
 128
 129             elsif Has_Drive_Letter
 130               and then BN'Length > 2
 131               and then Characters.Handling.Is_Letter (BN (BN'First))
 132               and then BN (BN'First + 1) = ':'
 133             then
 134                --  We have a DOS drive letter prefix, remove it
 135
 136                return BN (BN'First + 2 .. BN'Last);
 137
 138             else
 139                return BN;
 140             end if;
 141          end Check_For_Standard_Dirs;
 142       end Basename;
 143
 144    --  Start of processing for Base_Name
 145
 146    begin
 147       if Path'Length <= Suffix'Length then
 148          return Path;
 149       end if;
 150
 151       if Case_Sensitive_File_Name then
 152          return Basename (Path, Suffix);
 153       else
 154          return Basename
 155            (Characters.Handling.To_Lower (Path),
 156             Characters.Handling.To_Lower (Suffix));
 157       end if;
 158    end Base_Name;
 159
 160    ----------------
 161    -- Change_Dir --
 162    ----------------
 163
 164    procedure Change_Dir (Dir_Name : Dir_Name_Str) is
 165       C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
 166    begin
 167       if chdir (C_Dir_Name) /= 0 then
 168          raise Directory_Error;
 169       end if;
 170    end Change_Dir;
 171
 172    -----------
 173    -- Close --
 174    -----------
 175
 176    procedure Close (Dir : in out Dir_Type) is
 177       Discard : Integer;
 178       pragma Warnings (Off, Discard);
 179
 180       function closedir (directory : DIRs) return Integer;
 181       pragma Import (C, closedir, "__gnat_closedir");
 182
 183    begin
 184       if not Is_Open (Dir) then
 185          raise Directory_Error;
 186       end if;
 187
 188       Discard := closedir (DIRs (Dir.all));
 189       Free (Dir);
 190    end Close;
 191
 192    --------------
 193    -- Dir_Name --
 194    --------------
 195
 196    function Dir_Name (Path : Path_Name) return Dir_Name_Str is
 197       Last_DS : constant Natural :=
 198                   Strings.Fixed.Index
 199                     (Path, Dir_Seps, Going => Strings.Backward);
 200
 201    begin
 202       if Last_DS = 0 then
 203
 204          --  There is no directory separator, returns current working directory
 205
 206          return "." & Dir_Separator;
 207
 208       else
 209          return Path (Path'First .. Last_DS);
 210       end if;
 211    end Dir_Name;
 212
 213    -----------------
 214    -- Expand_Path --
 215    -----------------
 216
 217    function Expand_Path
 218      (Path : Path_Name;
 219       Mode : Environment_Style := System_Default) return Path_Name
 220    is
 221       Environment_Variable_Char : Character;
 222       pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
 223
 224       Result      : OS_Lib.String_Access := new String (1 .. 200);
 225       Result_Last : Natural := 0;
 226
 227       procedure Append (C : Character);
 228       procedure Append (S : String);
 229       --  Append to Result
 230
 231       procedure Double_Result_Size;
 232       --  Reallocate Result, doubling its size
 233
 234       function Is_Var_Prefix (C : Character) return Boolean;
 235       pragma Inline (Is_Var_Prefix);
 236
 237       procedure Read (K : in out Positive);
 238       --  Update Result while reading current Path starting at position K. If
 239       --  a variable is found, call Var below.
 240
 241       procedure Var (K : in out Positive);
 242       --  Translate variable name starting at position K with the associated
 243       --  environment value.
 244
 245       ------------
 246       -- Append --
 247       ------------
 248
 249       procedure Append (C : Character) is
 250       begin
 251          if Result_Last = Result'Last then
 252             Double_Result_Size;
 253          end if;
 254
 255          Result_Last := Result_Last + 1;
 256          Result (Result_Last) := C;
 257       end Append;
 258
 259       procedure Append (S : String) is
 260       begin
 261          while Result_Last + S'Length - 1 > Result'Last loop
 262             Double_Result_Size;
 263          end loop;
 264
 265          Result (Result_Last + 1 .. Result_Last + S'Length) := S;
 266          Result_Last := Result_Last + S'Length;
 267       end Append;
 268
 269       ------------------------
 270       -- Double_Result_Size --
 271       ------------------------
 272
 273       procedure Double_Result_Size is
 274          New_Result : constant OS_Lib.String_Access :=
 275                         new String (1 .. 2 * Result'Last);
 276       begin
 277          New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
 278          OS_Lib.Free (Result);
 279          Result := New_Result;
 280       end Double_Result_Size;
 281
 282       -------------------
 283       -- Is_Var_Prefix --
 284       -------------------
 285
 286       function Is_Var_Prefix (C : Character) return Boolean is
 287       begin
 288          return (C = Environment_Variable_Char and then Mode = System_Default)
 289            or else
 290              (C = '$' and then (Mode = UNIX or else Mode = Both))
 291            or else
 292              (C = '%' and then (Mode = DOS or else Mode = Both));
 293       end Is_Var_Prefix;
 294
 295       ----------
 296       -- Read --
 297       ----------
 298
 299       procedure Read (K : in out Positive) is
 300          P : Character;
 301
 302       begin
 303          For_All_Characters : loop
 304             if Is_Var_Prefix (Path (K)) then
 305                P := Path (K);
 306
 307                --  Could be a variable
 308
 309                if K < Path'Last then
 310                   if Path (K + 1) = P then
 311
 312                      --  Not a variable after all, this is a double $ or %,
 313                      --  just insert one in the result string.
 314
 315                      Append (P);
 316                      K := K + 1;
 317
 318                   else
 319                      --  Let's parse the variable
 320
 321                      Var (K);
 322                   end if;
 323
 324                else
 325                   --  We have an ending $ or % sign
 326
 327                   Append (P);
 328                end if;
 329
 330             else
 331                --  This is a standard character, just add it to the result
 332
 333                Append (Path (K));
 334             end if;
 335
 336             --  Skip to next character
 337
 338             K := K + 1;
 339
 340             exit For_All_Characters when K > Path'Last;
 341          end loop For_All_Characters;
 342       end Read;
 343
 344       ---------
 345       -- Var --
 346       ---------
 347
 348       procedure Var (K : in out Positive) is
 349          P : constant Character := Path (K);
 350          T : Character;
 351          E : Positive;
 352
 353       begin
 354          K := K + 1;
 355
 356          if P = '%' or else Path (K) = '{' then
 357
 358             --  Set terminator character
 359
 360             if P = '%' then
 361                T := '%';
 362             else
 363                T := '}';
 364                K := K + 1;
 365             end if;
 366
 367             --  Look for terminator character, k point to the first character
 368             --  for the variable name.
 369
 370             E := K;
 371
 372             loop
 373                E := E + 1;
 374                exit when Path (E) = T or else E = Path'Last;
 375             end loop;
 376
 377             if Path (E) = T then
 378
 379                --  OK found, translate with environment value
 380
 381                declare
 382                   Env : OS_Lib.String_Access :=
 383                           OS_Lib.Getenv (Path (K .. E - 1));
 384
 385                begin
 386                   Append (Env.all);
 387                   OS_Lib.Free (Env);
 388                end;
 389
 390             else
 391                --  No terminator character, not a variable after all or a
 392                --  syntax error, ignore it, insert string as-is.
 393
 394                Append (P);       --  Add prefix character
 395
 396                if T = '}' then   --  If we were looking for curly bracket
 397                   Append ('{');  --  terminator, add the curly bracket
 398                end if;
 399
 400                Append (Path (K .. E));
 401             end if;
 402
 403          else
 404             --  The variable name is everything from current position to first
 405             --  non letter/digit character.
 406
 407             E := K;
 408
 409             --  Check that first character is a letter
 410
 411             if Characters.Handling.Is_Letter (Path (E)) then
 412                E := E + 1;
 413
 414                Var_Name : loop
 415                   exit Var_Name when E > Path'Last;
 416
 417                   if Characters.Handling.Is_Letter (Path (E))
 418                     or else Characters.Handling.Is_Digit (Path (E))
 419                   then
 420                      E := E + 1;
 421                   else
 422                      exit Var_Name;
 423                   end if;
 424                end loop Var_Name;
 425
 426                E := E - 1;
 427
 428                declare
 429                   Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E));
 430
 431                begin
 432                   Append (Env.all);
 433                   OS_Lib.Free (Env);
 434                end;
 435
 436             else
 437                --  This is not a variable after all
 438
 439                Append ('$');
 440                Append (Path (E));
 441             end if;
 442
 443          end if;
 444
 445          K := E;
 446       end Var;
 447
 448    --  Start of processing for Expand_Path
 449
 450    begin
 451       declare
 452          K : Positive := Path'First;
 453
 454       begin
 455          Read (K);
 456
 457          declare
 458             Returned_Value : constant String := Result (1 .. Result_Last);
 459
 460          begin
 461             OS_Lib.Free (Result);
 462             return Returned_Value;
 463          end;
 464       end;
 465    end Expand_Path;
 466
 467    --------------------
 468    -- File_Extension --
 469    --------------------
 470
 471    function File_Extension (Path : Path_Name) return String is
 472       First : Natural :=
 473                 Strings.Fixed.Index
 474                   (Path, Dir_Seps, Going => Strings.Backward);
 475
 476       Dot : Natural;
 477
 478    begin
 479       if First = 0 then
 480          First := Path'First;
 481       end if;
 482
 483       Dot := Strings.Fixed.Index (Path (First .. Path'Last),
 484                                   ".",
 485                                   Going => Strings.Backward);
 486
 487       if Dot = 0 or else Dot = Path'Last then
 488          return "";
 489       else
 490          return Path (Dot .. Path'Last);
 491       end if;
 492    end File_Extension;
 493
 494    ---------------
 495    -- File_Name --
 496    ---------------
 497
 498    function File_Name (Path : Path_Name) return String is
 499    begin
 500       return Base_Name (Path);
 501    end File_Name;
 502
 503    ---------------------
 504    -- Format_Pathname --
 505    ---------------------
 506
 507    function Format_Pathname
 508      (Path  : Path_Name;
 509       Style : Path_Style := System_Default) return String
 510    is
 511       N_Path       : String   := Path;
 512       K            : Positive := N_Path'First;
 513       Prev_Dirsep  : Boolean  := False;
 514
 515    begin
 516       if Dir_Separator = '\'
 517         and then Path'Length > 1
 518         and then Path (K .. K + 1) = "\\"
 519       then
 520          if Style = UNIX then
 521             N_Path (K .. K + 1) := "//";
 522          end if;
 523
 524          K := K + 2;
 525       end if;
 526
 527       for J in K .. Path'Last loop
 528          if Strings.Maps.Is_In (Path (J), Dir_Seps) then
 529             if not Prev_Dirsep then
 530                case Style is
 531                   when UNIX           => N_Path (K) := '/';
 532                   when DOS            => N_Path (K) := '\';
 533                   when System_Default => N_Path (K) := Dir_Separator;
 534                end case;
 535
 536                K := K + 1;
 537             end if;
 538
 539             Prev_Dirsep := True;
 540
 541          else
 542             N_Path (K) := Path (J);
 543             K := K + 1;
 544             Prev_Dirsep := False;
 545          end if;
 546       end loop;
 547
 548       return N_Path (N_Path'First .. K - 1);
 549    end Format_Pathname;
 550
 551    ---------------------
 552    -- Get_Current_Dir --
 553    ---------------------
 554
 555    Max_Path : Integer;
 556    pragma Import (C, Max_Path, "__gnat_max_path_len");
 557
 558    function Get_Current_Dir return Dir_Name_Str is
 559       Current_Dir : String (1 .. Max_Path + 1);
 560       Last        : Natural;
 561    begin
 562       Get_Current_Dir (Current_Dir, Last);
 563       return Current_Dir (1 .. Last);
 564    end Get_Current_Dir;
 565
 566    procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
 567       Path_Len : Natural := Max_Path;
 568       Buffer   : String (Dir'First .. Dir'First + Max_Path + 1);
 569
 570       procedure Local_Get_Current_Dir
 571         (Dir    : System.Address;
 572          Length : System.Address);
 573       pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
 574
 575    begin
 576       Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
 577
 578       Last :=
 579         (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);
 580
 581       Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
 582
 583       --  By default, the drive letter on Windows is in upper case
 584
 585       if On_Windows and then Last > Dir'First and then
 586         Dir (Dir'First + 1) = ':'
 587       then
 588          Dir (Dir'First) :=
 589            Ada.Characters.Handling.To_Upper (Dir (Dir'First));
 590       end if;
 591    end Get_Current_Dir;
 592
 593    -------------
 594    -- Is_Open --
 595    -------------
 596
 597    function Is_Open (Dir : Dir_Type) return Boolean is
 598    begin
 599       return Dir /= Null_Dir
 600         and then System.Address (Dir.all) /= System.Null_Address;
 601    end Is_Open;
 602
 603    --------------
 604    -- Make_Dir --
 605    --------------
 606
 607    procedure Make_Dir (Dir_Name : Dir_Name_Str) is
 608       C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
 609
 610       function mkdir (Dir_Name : String) return Integer;
 611       pragma Import (C, mkdir, "__gnat_mkdir");
 612
 613    begin
 614       if mkdir (C_Dir_Name) /= 0 then
 615          raise Directory_Error;
 616       end if;
 617    end Make_Dir;
 618
 619    ----------
 620    -- Open --
 621    ----------
 622
 623    procedure Open
 624      (Dir      : out Dir_Type;
 625       Dir_Name : Dir_Name_Str)
 626    is
 627       function opendir (file_name : String) return DIRs;
 628       pragma Import (C, opendir, "__gnat_opendir");
 629
 630       C_File_Name : constant String := Dir_Name & ASCII.NUL;
 631
 632    begin
 633       Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name)));
 634
 635       if not Is_Open (Dir) then
 636          Free (Dir);
 637          Dir := Null_Dir;
 638          raise Directory_Error;
 639       end if;
 640    end Open;
 641
 642    ----------
 643    -- Read --
 644    ----------
 645
 646    procedure Read
 647      (Dir  : Dir_Type;
 648       Str  : out String;
 649       Last : out Natural)
 650    is
 651       Filename_Addr : Address;
 652       Filename_Len  : aliased Integer;
 653
 654       Buffer : array (0 .. Filename_Max + 12) of Character;
 655       --  12 is the size of the dirent structure (see dirent.h), without the
 656       --  field for the filename.
 657
 658       function readdir_gnat
 659         (Directory : System.Address;
 660          Buffer    : System.Address;
 661          Last      : not null access Integer) return System.Address;
 662       pragma Import (C, readdir_gnat, "__gnat_readdir");
 663
 664    begin
 665       if not Is_Open (Dir) then
 666          raise Directory_Error;
 667       end if;
 668
 669       Filename_Addr :=
 670         readdir_gnat
 671           (System.Address (Dir.all), Buffer'Address, Filename_Len'Access);
 672
 673       if Filename_Addr = System.Null_Address then
 674          Last := 0;
 675          return;
 676       end if;
 677
 678       Last :=
 679         (if Str'Length > Filename_Len then Str'First + Filename_Len - 1
 680          else Str'Last);
 681
 682       declare
 683          subtype Path_String is String (1 .. Filename_Len);
 684          type    Path_String_Access is access Path_String;
 685
 686          function Address_To_Access is new
 687            Ada.Unchecked_Conversion
 688              (Source => Address,
 689               Target => Path_String_Access);
 690
 691          Path_Access : constant Path_String_Access :=
 692                          Address_To_Access (Filename_Addr);
 693
 694       begin
 695          for J in Str'First .. Last loop
 696             Str (J) := Path_Access (J - Str'First + 1);
 697          end loop;
 698       end;
 699    end Read;
 700
 701    -------------------------
 702    -- Read_Is_Thread_Sage --
 703    -------------------------
 704
 705    function Read_Is_Thread_Safe return Boolean is
 706       function readdir_is_thread_safe return Integer;
 707       pragma Import
 708         (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
 709    begin
 710       return (readdir_is_thread_safe /= 0);
 711    end Read_Is_Thread_Safe;
 712
 713    ----------------
 714    -- Remove_Dir --
 715    ----------------
 716
 717    procedure Remove_Dir
 718      (Dir_Name  : Dir_Name_Str;
 719       Recursive : Boolean := False)
 720    is
 721       C_Dir_Name  : constant String := Dir_Name & ASCII.NUL;
 722       Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
 723       Last        : Integer;
 724       Str         : String (1 .. Filename_Max);
 725       Success     : Boolean;
 726       Working_Dir : Dir_Type;
 727
 728    begin
 729       --  Remove the directory only if it is empty
 730
 731       if not Recursive then
 732          if rmdir (C_Dir_Name) /= 0 then
 733             raise Directory_Error;
 734          end if;
 735
 736       --  Remove directory and all files and directories that it may contain
 737
 738       else
 739          --  Substantial comments needed. See RH for revision 1.50 ???
 740
 741          begin
 742             Change_Dir (Dir_Name);
 743             Open (Working_Dir, ".");
 744
 745             loop
 746                Read (Working_Dir, Str, Last);
 747                exit when Last = 0;
 748
 749                if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
 750                   if Str (1 .. Last) /= "."
 751                        and then
 752                      Str (1 .. Last) /= ".."
 753                   then
 754                      Remove_Dir (Str (1 .. Last), True);
 755                   end if;
 756
 757                else
 758                   GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
 759
 760                   if not Success then
 761                      Change_Dir (Current_Dir);
 762                      raise Directory_Error;
 763                   end if;
 764                end if;
 765             end loop;
 766
 767             Change_Dir (Current_Dir);
 768             Close (Working_Dir);
 769             Remove_Dir (Dir_Name);
 770
 771          exception
 772             when others =>
 773
 774                --  An exception occurred. We must make sure the current working
 775                --  directory is unchanged.
 776
 777                Change_Dir (Current_Dir);
 778
 779                --  What if the Change_Dir raises an exception itself, shouldn't
 780                --  that be protected? ???
 781
 782                raise;
 783          end;
 784       end if;
 785    end Remove_Dir;
 786
 787 end GNAT.Directory_Operations;