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