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