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