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