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