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 --                                                                          --
  10 --            Copyright (C) 1998-2001 Ada Core Technologies, Inc.           --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  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    procedure Free is new
  52      Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
  53
  54    ---------------
  55    -- Base_Name --
  56    ---------------
  57
  58    function Base_Name
  59      (Path   : Path_Name;
  60       Suffix : String    := "")
  61       return   String
  62    is
  63       function Get_File_Names_Case_Sensitive return Integer;
  64       pragma Import
  65         (C, Get_File_Names_Case_Sensitive,
  66          "__gnat_get_file_names_case_sensitive");
  67
  68       Case_Sensitive_File_Name : constant Boolean :=
  69                                    Get_File_Names_Case_Sensitive = 1;
  70
  71       function Basename
  72         (Path   : Path_Name;
  73          Suffix : String    := "")
  74          return String;
  75       --  This function does the job. The only difference between Basename
  76       --  and Base_Name (the parent function) is that the former is case
  77       --  sensitive, while the latter is not. Path and Suffix are adjusted
  78       --  appropriately before calling Basename under platforms where the
  79       --  file system is not case sensitive.
  80
  81       --------------
  82       -- Basename --
  83       --------------
  84
  85       function Basename
  86         (Path   : Path_Name;
  87          Suffix : String    := "")
  88          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          begin
 124             if BN = "." or else BN = ".." then
 125                return "";
 126
 127             elsif BN'Length > 2
 128               and then Characters.Handling.Is_Letter (BN (BN'First))
 129               and then BN (BN'First + 1) = ':'
 130             then
 131                --  We have a DOS drive letter prefix, remove it
 132
 133                return BN (BN'First + 2 .. BN'Last);
 134
 135             else
 136                return BN;
 137             end if;
 138          end Check_For_Standard_Dirs;
 139       end Basename;
 140
 141    --  Start processing for Base_Name
 142
 143    begin
 144       if Case_Sensitive_File_Name then
 145          return Basename (Path, Suffix);
 146
 147       else
 148          return Basename
 149            (Characters.Handling.To_Lower (Path),
 150             Characters.Handling.To_Lower (Suffix));
 151       end if;
 152    end Base_Name;
 153
 154    ----------------
 155    -- Change_Dir --
 156    ----------------
 157
 158    procedure Change_Dir (Dir_Name : Dir_Name_Str) is
 159       C_Dir_Name : String := Dir_Name & ASCII.NUL;
 160
 161       function chdir (Dir_Name : String) return Integer;
 162       pragma Import (C, chdir, "chdir");
 163
 164    begin
 165       if chdir (C_Dir_Name) /= 0 then
 166          raise Directory_Error;
 167       end if;
 168    end Change_Dir;
 169
 170    -----------
 171    -- Close --
 172    -----------
 173
 174    procedure Close (Dir : in out Dir_Type) is
 175
 176       function closedir (Directory : System.Address) return Integer;
 177       pragma Import (C, closedir, "closedir");
 178
 179       Discard : Integer;
 180
 181    begin
 182       if not Is_Open (Dir) then
 183          raise Directory_Error;
 184       end if;
 185
 186       Discard := closedir (System.Address (Dir.all));
 187       Free (Dir);
 188    end Close;
 189
 190    --------------
 191    -- Dir_Name --
 192    --------------
 193
 194    function Dir_Name (Path : Path_Name) return Dir_Name_Str is
 195       Last_DS : constant Natural :=
 196                   Strings.Fixed.Index
 197                     (Path, Dir_Seps, Going => Strings.Backward);
 198
 199    begin
 200       if Last_DS = 0 then
 201
 202          --  There is no directory separator, returns current working directory
 203
 204          return "." & Dir_Separator;
 205
 206       else
 207          return Path (Path'First .. Last_DS);
 208       end if;
 209    end Dir_Name;
 210
 211    -----------------
 212    -- Expand_Path --
 213    -----------------
 214
 215    function Expand_Path (Path : Path_Name) return String is
 216
 217       Result      : OS_Lib.String_Access := new String (1 .. 200);
 218       Result_Last : Natural := 0;
 219
 220       procedure Append (C : Character);
 221       procedure Append (S : String);
 222       --  Append to Result
 223
 224       procedure Double_Result_Size;
 225       --  Reallocate Result, doubling its size
 226
 227       procedure Read (K : in out Positive);
 228       --  Update Result while reading current Path starting at position K. If
 229       --  a variable is found, call Var below.
 230
 231       procedure Var (K : in out Positive);
 232       --  Translate variable name starting at position K with the associated
 233       --  environment value.
 234
 235       ------------
 236       -- Append --
 237       ------------
 238
 239       procedure Append (C : Character) is
 240       begin
 241          if Result_Last = Result'Last then
 242             Double_Result_Size;
 243          end if;
 244
 245          Result_Last := Result_Last + 1;
 246          Result (Result_Last) := C;
 247       end Append;
 248
 249       procedure Append (S : String) is
 250       begin
 251          while Result_Last + S'Length - 1 > Result'Last loop
 252             Double_Result_Size;
 253          end loop;
 254
 255          Result (Result_Last + 1 .. Result_Last + S'Length) := S;
 256          Result_Last := Result_Last + S'Length;
 257       end Append;
 258
 259       ------------------------
 260       -- Double_Result_Size --
 261       ------------------------
 262
 263       procedure Double_Result_Size is
 264          New_Result : constant OS_Lib.String_Access :=
 265            new String (1 .. 2 * Result'Last);
 266
 267       begin
 268          New_Result (1 .. Result_Last) := Result (1 .. Result_Last);
 269          OS_Lib.Free (Result);
 270          Result := New_Result;
 271       end Double_Result_Size;
 272
 273       ----------
 274       -- Read --
 275       ----------
 276
 277       procedure Read (K : in out Positive) is
 278       begin
 279          For_All_Characters : loop
 280             if Path (K) = '$' then
 281
 282                --  Could be a variable
 283
 284                if K < Path'Last then
 285
 286                   if Path (K + 1) = '$' then
 287
 288                      --  Not a variable after all, this is a double $, just
 289                      --  insert one in the result string.
 290
 291                      Append ('$');
 292                      K := K + 1;
 293
 294                   else
 295                      --  Let's parse the variable
 296
 297                      K := K + 1;
 298                      Var (K);
 299                   end if;
 300
 301                else
 302                   --  We have an ending $ sign
 303
 304                   Append ('$');
 305                end if;
 306
 307             else
 308                --  This is a standard character, just add it to the result
 309
 310                Append (Path (K));
 311             end if;
 312
 313             --  Skip to next character
 314
 315             K := K + 1;
 316
 317             exit For_All_Characters when K > Path'Last;
 318          end loop For_All_Characters;
 319       end Read;
 320
 321       ---------
 322       -- Var --
 323       ---------
 324
 325       procedure Var (K : in out Positive) is
 326          E : Positive;
 327
 328       begin
 329          if Path (K) = '{' then
 330
 331             --  Look for closing } (curly bracket).
 332
 333             E := K;
 334
 335             loop
 336                E := E + 1;
 337                exit when Path (E) = '}' or else E = Path'Last;
 338             end loop;
 339
 340             if Path (E) = '}' then
 341
 342                --  OK found, translate with environment value
 343
 344                declare
 345                   Env : OS_Lib.String_Access :=
 346                           OS_Lib.Getenv (Path (K + 1 .. E - 1));
 347
 348                begin
 349                   Append (Env.all);
 350                   OS_Lib.Free (Env);
 351                end;
 352
 353             else
 354                --  No closing curly bracket, not a variable after all or a
 355                --  syntax error, ignore it, insert string as-is.
 356
 357                Append ('$');
 358                Append (Path (K .. E));
 359             end if;
 360
 361          else
 362             --  The variable name is everything from current position to first
 363             --  non letter/digit character.
 364
 365             E := K;
 366
 367             --  Check that first chartacter is a letter
 368
 369             if Characters.Handling.Is_Letter (Path (E)) then
 370                E := E + 1;
 371
 372                Var_Name : loop
 373                   exit Var_Name when E > Path'Last;
 374
 375                   if Characters.Handling.Is_Letter (Path (E))
 376                     or else Characters.Handling.Is_Digit (Path (E))
 377                   then
 378                      E := E + 1;
 379                   else
 380                      exit Var_Name;
 381                   end if;
 382                end loop Var_Name;
 383
 384                E := E - 1;
 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    -- Format_Pathname --
 463    ---------------------
 464
 465    function Format_Pathname
 466      (Path  : Path_Name;
 467       Style : Path_Style := System_Default)
 468       return  String
 469    is
 470       N_Path      : String   := Path;
 471       K           : Positive := N_Path'First;
 472       Prev_Dirsep : Boolean  := False;
 473
 474    begin
 475       for J in Path'Range loop
 476
 477          if Strings.Maps.Is_In (Path (J), Dir_Seps) then
 478             if not Prev_Dirsep then
 479                case Style is
 480                   when UNIX           => N_Path (K) := '/';
 481                   when DOS            => N_Path (K) := '\';
 482                   when System_Default => N_Path (K) := Dir_Separator;
 483                end case;
 484
 485                K := K + 1;
 486             end if;
 487
 488             Prev_Dirsep := True;
 489
 490          else
 491             N_Path (K) := Path (J);
 492             K := K + 1;
 493             Prev_Dirsep := False;
 494          end if;
 495       end loop;
 496
 497       return N_Path (N_Path'First .. K - 1);
 498    end Format_Pathname;
 499
 500    ---------------------
 501    -- Get_Current_Dir --
 502    ---------------------
 503
 504    Max_Path : Integer;
 505    pragma Import (C, Max_Path, "__gnat_max_path_len");
 506
 507    function Get_Current_Dir return Dir_Name_Str is
 508       Current_Dir : String (1 .. Max_Path + 1);
 509       Last        : Natural;
 510
 511    begin
 512       Get_Current_Dir (Current_Dir, Last);
 513       return Current_Dir (1 .. Last);
 514    end Get_Current_Dir;
 515
 516    procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is
 517       Path_Len : Natural := Max_Path;
 518       Buffer   : String (Dir'First .. Dir'First + Max_Path + 1);
 519
 520       procedure Local_Get_Current_Dir
 521         (Dir    : System.Address;
 522          Length : System.Address);
 523       pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir");
 524
 525    begin
 526       Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
 527
 528       if Dir'Length > Path_Len then
 529          Last := Dir'First + Path_Len - 1;
 530       else
 531          Last := Dir'Last;
 532       end if;
 533
 534       Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last);
 535    end Get_Current_Dir;
 536
 537    -------------
 538    -- Is_Open --
 539    -------------
 540
 541    function Is_Open (Dir : Dir_Type) return Boolean is
 542    begin
 543       return Dir /= Null_Dir
 544         and then System.Address (Dir.all) /= System.Null_Address;
 545    end Is_Open;
 546
 547    --------------
 548    -- Make_Dir --
 549    --------------
 550
 551    procedure Make_Dir (Dir_Name : Dir_Name_Str) is
 552       C_Dir_Name : String := Dir_Name & ASCII.NUL;
 553
 554       function mkdir (Dir_Name : String) return Integer;
 555       pragma Import (C, mkdir, "__gnat_mkdir");
 556
 557    begin
 558       if mkdir (C_Dir_Name) /= 0 then
 559          raise Directory_Error;
 560       end if;
 561    end Make_Dir;
 562
 563    ----------
 564    -- Open --
 565    ----------
 566
 567    procedure Open
 568      (Dir      : out Dir_Type;
 569       Dir_Name : Dir_Name_Str)
 570    is
 571       C_File_Name : String := Dir_Name & ASCII.NUL;
 572
 573       function opendir
 574         (File_Name : String)
 575          return      Dir_Type_Value;
 576       pragma Import (C, opendir, "opendir");
 577
 578    begin
 579       Dir := new Dir_Type_Value'(opendir (C_File_Name));
 580
 581       if not Is_Open (Dir) then
 582          Free (Dir);
 583          Dir := Null_Dir;
 584          raise Directory_Error;
 585       end if;
 586    end Open;
 587
 588    ----------
 589    -- Read --
 590    ----------
 591
 592    procedure Read
 593      (Dir  : in out Dir_Type;
 594       Str  : out String;
 595       Last : out Natural)
 596    is
 597       Filename_Addr : Address;
 598       Filename_Len  : Integer;
 599
 600       Buffer : array (0 .. 1024) of Character;
 601       --  1024 is the value of FILENAME_MAX in stdio.h
 602
 603       function readdir_gnat
 604         (Directory : System.Address;
 605          Buffer    : System.Address)
 606          return      System.Address;
 607       pragma Import (C, readdir_gnat, "__gnat_readdir");
 608
 609       function strlen (S : Address) return Integer;
 610       pragma Import (C, strlen, "strlen");
 611
 612    begin
 613       if not Is_Open (Dir) then
 614          raise Directory_Error;
 615       end if;
 616
 617       Filename_Addr :=
 618         readdir_gnat (System.Address (Dir.all), Buffer'Address);
 619
 620       if Filename_Addr = System.Null_Address then
 621          Last := 0;
 622          return;
 623       end if;
 624
 625       Filename_Len  := strlen (Filename_Addr);
 626
 627       if Str'Length > Filename_Len then
 628          Last := Str'First + Filename_Len - 1;
 629       else
 630          Last := Str'Last;
 631       end if;
 632
 633       declare
 634          subtype Path_String is String (1 .. Filename_Len);
 635          type    Path_String_Access is access Path_String;
 636
 637          function Address_To_Access is new
 638            Unchecked_Conversion
 639              (Source => Address,
 640               Target => Path_String_Access);
 641
 642          Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
 643
 644       begin
 645          for J in Str'First .. Last loop
 646             Str (J) := Path_Access (J - Str'First + 1);
 647          end loop;
 648       end;
 649    end Read;
 650
 651    -------------------------
 652    -- Read_Is_Thread_Sage --
 653    -------------------------
 654
 655    function Read_Is_Thread_Safe return Boolean is
 656
 657       function readdir_is_thread_safe return Integer;
 658       pragma Import
 659         (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe");
 660
 661    begin
 662       return (readdir_is_thread_safe /= 0);
 663    end Read_Is_Thread_Safe;
 664
 665    ----------------
 666    -- Remove_Dir --
 667    ----------------
 668
 669    procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
 670       C_Dir_Name : String := Dir_Name & ASCII.NUL;
 671
 672       procedure rmdir (Dir_Name : String);
 673       pragma Import (C, rmdir, "rmdir");
 674
 675    begin
 676       rmdir (C_Dir_Name);
 677    end Remove_Dir;
 678
 679 end GNAT.Directory_Operations;