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