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