gcc/ada/gprcmd.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               G P R C M D                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --         Copyright (C) 2002-2004 Free Software Foundation, 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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  A utility used by Makefile.generic to handle multi-language builds.
  28 --  gprcmd provides a set of commands so that the makefiles do not need
  29 --  to depend on unix utilities not available on all targets.
  30
  31 --  The list of commands recognized by gprcmd are:
  32
  33 --    pwd          display current directory
  34 --    to_lower     display next argument in lower case
  35 --    to_absolute  convert pathnames to absolute directories when needed
  36 --    cat          dump contents of a given file
  37 --    extend       handle recursive directories ("/**" notation)
  38 --    deps         post process dependency makefiles
  39 --    stamp        copy file time stamp from file1 to file2
  40 --    prefix       get the prefix of the GNAT installation
  41 --    path         convert a list of directories to a path list, inserting a
  42 --                 path separator after each directory, including the last one
  43 --    ignore       do nothing
  44
  45 with Gnatvsn;
  46 with Osint;   use Osint;
  47 with Namet;   use Namet;
  48
  49 with Ada.Characters.Handling;   use Ada.Characters.Handling;
  50 with Ada.Command_Line;          use Ada.Command_Line;
  51 with Ada.Text_IO;               use Ada.Text_IO;
  52 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  53 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  54 with GNAT.Regpat;               use GNAT.Regpat;
  55
  56
  57 procedure Gprcmd is
  58
  59    --  ??? comments are thin throughout this unit
  60
  61    Gprdebug : constant String  := To_Lower (Getenv ("GPRDEBUG").all);
  62    Debug    : constant Boolean := Gprdebug = "true";
  63    --  When Debug is True, gprcmd displays its arguments to Standard_Error.
  64    --  This is to help to debug.
  65
  66    procedure Cat (File : String);
  67    --  Print the contents of file on standard output.
  68    --  If the file cannot be read, exit the process with an error code.
  69
  70    procedure Check_Args (Condition : Boolean);
  71    --  If Condition is false, print command invoked, then the usage,
  72    --  and exit the process.
  73
  74    procedure Deps (Objext : String; File : String; GCC : Boolean);
  75    --  Process $(CC) dependency file. If GCC is True, add a rule so that make
  76    --  will not complain when a file is removed/added. If GCC is False, add a
  77    --  rule to recompute the dependency file when needed
  78
  79    procedure Extend (Dir : String);
  80    --  If Dir ends with /**, Put all subdirs recursively on standard output,
  81    --  otherwise put Dir.
  82
  83    procedure Usage;
  84    --  Display the command line options and exit the process.
  85
  86    procedure Copy_Time_Stamp (From, To : String);
  87    --  Copy file time stamp from file From to file To.
  88
  89    procedure Display_Command;
  90    --  Display the invoked command to Standard_Error
  91
  92    ---------
  93    -- Cat --
  94    ---------
  95
  96    procedure Cat (File : String) is
  97       FD     : File_Descriptor;
  98       Buffer : String_Access;
  99       Length : Integer;
 100
 101    begin
 102       FD := Open_Read (File, Fmode => Binary);
 103
 104       if FD = Invalid_FD then
 105          OS_Exit (2);
 106       end if;
 107
 108       Length := Integer (File_Length (FD));
 109       Buffer := new String (1 .. Length);
 110       Length := Read (FD, Buffer.all'Address, Length);
 111       Close (FD);
 112       Put (Buffer.all);
 113       Free (Buffer);
 114    end Cat;
 115
 116    ----------------
 117    -- Check_Args --
 118    ----------------
 119
 120    procedure Check_Args (Condition : Boolean) is
 121    begin
 122       if not Condition then
 123          Put_Line
 124            (Standard_Error,
 125             "bad call to gprcmd with" & Argument_Count'Img & " arguments.");
 126
 127          for J in 0 .. Argument_Count loop
 128             Put (Standard_Error, Argument (J) & " ");
 129          end loop;
 130
 131          New_Line (Standard_Error);
 132
 133          Usage;
 134       end if;
 135    end Check_Args;
 136
 137    ---------------------
 138    -- Copy_Time_Stamp --
 139    ---------------------
 140
 141    procedure Copy_Time_Stamp (From, To : String) is
 142       function Copy_Attributes
 143         (From, To : String;
 144          Mode     : Integer) return Integer;
 145       pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
 146       --  Mode = 0 - copy only time stamps.
 147       --  Mode = 1 - copy time stamps and read/write/execute attributes
 148
 149       FD : File_Descriptor;
 150
 151    begin
 152       if not Is_Regular_File (From) then
 153          return;
 154       end if;
 155
 156       FD := Create_File (To, Fmode => Binary);
 157
 158       if FD = Invalid_FD then
 159          OS_Exit (2);
 160       end if;
 161
 162       Close (FD);
 163
 164       if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
 165          OS_Exit (2);
 166       end if;
 167    end Copy_Time_Stamp;
 168
 169    ----------
 170    -- Deps --
 171    ----------
 172
 173    procedure Deps (Objext : String; File : String; GCC : Boolean) is
 174       Colon      : constant String := ':' & ASCII.LF;
 175       NL         : constant String := (1 => ASCII.LF);
 176       Base       : constant String := ' ' & Base_Name (File) & ": ";
 177       FD         : File_Descriptor;
 178       Buffer     : String_Access;
 179       Length     : Integer;
 180       Obj_Regexp : constant Pattern_Matcher :=
 181                      Compile ("^.*\" & Objext & ": ");
 182       Matched    : Match_Array (0 .. 0);
 183       Start      : Natural;
 184       First      : Natural;
 185       Last       : Natural;
 186
 187    begin
 188       FD := Open_Read_Write (File, Fmode => Binary);
 189
 190       if FD = Invalid_FD then
 191          return;
 192       end if;
 193
 194       Length := Integer (File_Length (FD));
 195       Buffer := new String (1 .. Length);
 196       Length := Read (FD, Buffer.all'Address, Length);
 197
 198       if GCC then
 199          Lseek (FD, 0, Seek_End);
 200       else
 201          Close (FD);
 202          FD := Create_File (File, Fmode => Binary);
 203       end if;
 204
 205       Start := Buffer'First;
 206
 207       while Start <= Buffer'Last loop
 208
 209          --  Parse Buffer line by line
 210
 211          while Start < Buffer'Last
 212            and then (Buffer (Start) = ASCII.CR
 213                      or else Buffer (Start) = ASCII.LF)
 214          loop
 215             Start := Start + 1;
 216          end loop;
 217
 218          Last := Start;
 219
 220          while Last < Buffer'Last
 221            and then Buffer (Last + 1) /= ASCII.CR
 222            and then Buffer (Last + 1) /= ASCII.LF
 223          loop
 224             Last := Last + 1;
 225          end loop;
 226
 227          Match (Obj_Regexp, Buffer (Start .. Last), Matched);
 228
 229          if GCC then
 230             if Matched (0) = No_Match then
 231                First := Start;
 232             else
 233                First := Matched (0).Last + 1;
 234             end if;
 235
 236             Length := Write (FD, Buffer (First)'Address, Last - First + 1);
 237
 238             if Start = Last or else Buffer (Last) = '\' then
 239                Length := Write (FD, NL (1)'Address, NL'Length);
 240             else
 241                Length := Write (FD, Colon (1)'Address, Colon'Length);
 242             end if;
 243
 244          else
 245             if Matched (0) = No_Match then
 246                First := Start;
 247             else
 248                Length :=
 249                  Write (FD, Buffer (Start)'Address,
 250                         Matched (0).Last - Start - 1);
 251                Length := Write (FD, Base (Base'First)'Address, Base'Length);
 252                First := Matched (0).Last + 1;
 253             end if;
 254
 255             Length := Write (FD, Buffer (First)'Address, Last - First + 1);
 256             Length := Write (FD, NL (1)'Address, NL'Length);
 257          end if;
 258
 259          Start := Last + 1;
 260       end loop;
 261
 262       Close (FD);
 263       Free (Buffer);
 264    end Deps;
 265
 266    ---------------------
 267    -- Display_Command --
 268    ---------------------
 269
 270    procedure Display_Command is
 271    begin
 272       for J in 0 .. Argument_Count loop
 273          Put (Standard_Error, Argument (J) & ' ');
 274       end loop;
 275
 276       New_Line (Standard_Error);
 277    end Display_Command;
 278
 279    ------------
 280    -- Extend --
 281    ------------
 282
 283    procedure Extend (Dir : String) is
 284
 285       procedure Recursive_Extend (D : String);
 286       --  Recursively display all subdirectories of D
 287
 288       ----------------------
 289       -- Recursive_Extend --
 290       ----------------------
 291
 292       procedure Recursive_Extend (D : String) is
 293          Iter   : Dir_Type;
 294          Buffer : String (1 .. 8192);
 295          Last   : Natural;
 296
 297       begin
 298          Open (Iter, D);
 299
 300          loop
 301             Read (Iter, Buffer, Last);
 302
 303             exit when Last = 0;
 304
 305             if Buffer (1 .. Last) /= "."
 306               and then Buffer (1 .. Last) /= ".."
 307             then
 308                declare
 309                   Abs_Dir : constant String := D & Buffer (1 .. Last);
 310
 311                begin
 312                   if Is_Directory (Abs_Dir)
 313                     and then not Is_Symbolic_Link (Abs_Dir)
 314                   then
 315                      Put (' ' & Abs_Dir);
 316                      Recursive_Extend (Abs_Dir & '/');
 317                   end if;
 318                end;
 319             end if;
 320          end loop;
 321
 322          Close (Iter);
 323
 324       exception
 325          when Directory_Error =>
 326             null;
 327       end Recursive_Extend;
 328
 329    --  Start of processing for Extend
 330
 331    begin
 332       if Dir'Length < 3
 333         or else (Dir (Dir'Last - 2) /= '/'
 334                  and then Dir (Dir'Last - 2) /= Directory_Separator)
 335         or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
 336       then
 337          Put (Dir);
 338          return;
 339       end if;
 340
 341       declare
 342          D : constant String := Dir (Dir'First .. Dir'Last - 2);
 343       begin
 344          Put (D);
 345          Recursive_Extend (D);
 346       end;
 347    end Extend;
 348
 349    -----------
 350    -- Usage --
 351    -----------
 352
 353    procedure Usage is
 354    begin
 355       Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
 356       Put_Line (Standard_Error, "where cmd is one of the following commands:");
 357       Put_Line (Standard_Error, "  pwd         " &
 358                                 "display current directory");
 359       Put_Line (Standard_Error, "  to_lower    " &
 360                                 "display next argument in lower case");
 361       Put_Line (Standard_Error, "  to_absolute " &
 362                                 "convert pathnames to absolute " &
 363                                 "directories when needed");
 364       Put_Line (Standard_Error, "  cat         " &
 365                                 "dump contents of a given file");
 366       Put_Line (Standard_Error, "  extend      " &
 367                                 "handle recursive directories " &
 368                                 "(""/**"" notation)");
 369       Put_Line (Standard_Error, "  deps        " &
 370                                 "post process dependency makefiles");
 371       Put_Line (Standard_Error, "  stamp       " &
 372                                 "copy file time stamp from file1 to file2");
 373       Put_Line (Standard_Error, "  prefix      " &
 374                                 "get the prefix of the GNAT installation");
 375       Put_Line (Standard_Error, "  path_sep    " &
 376                                 "returns the path separator");
 377       Put_Line (Standard_Error, "  linkopts      " &
 378                                 "process attribute Linker'Linker_Options");
 379       Put_Line (Standard_Error, "  ignore      " &
 380                                 "do nothing");
 381       OS_Exit (1);
 382    end Usage;
 383
 384 --  Start of processing for Gprcmd
 385
 386 begin
 387    if Debug then
 388       Display_Command;
 389    end if;
 390
 391    Check_Args (Argument_Count > 0);
 392
 393    declare
 394       Cmd : constant String := Argument (1);
 395
 396    begin
 397       if Cmd = "-v" then
 398
 399          --  Output on standard error, because only returned values should
 400          --  go to standard output.
 401
 402          Put (Standard_Error, "GPRCMD ");
 403          Put (Standard_Error, Gnatvsn.Gnat_Version_String);
 404          Put_Line (Standard_Error,
 405                    " Copyright 2002-2004, Free Software Fundation, Inc.");
 406          Usage;
 407
 408       elsif Cmd = "pwd" then
 409          Put (Format_Pathname (Get_Current_Dir, UNIX));
 410
 411       elsif Cmd = "cat" then
 412          Check_Args (Argument_Count = 2);
 413          Cat (Argument (2));
 414
 415       elsif Cmd = "to_lower" then
 416          Check_Args (Argument_Count >= 2);
 417
 418          for J in 2 .. Argument_Count loop
 419             Put (To_Lower (Argument (J)));
 420
 421             if J < Argument_Count then
 422                Put (' ');
 423             end if;
 424          end loop;
 425
 426       elsif Cmd = "to_absolute" then
 427          Check_Args (Argument_Count > 2);
 428
 429          declare
 430             Dir : constant String := Argument (2);
 431
 432          begin
 433             for J in 3 .. Argument_Count loop
 434                if Is_Absolute_Path (Argument (J)) then
 435                   Put (Format_Pathname (Argument (J), UNIX));
 436                else
 437                   Put (Format_Pathname
 438                          (Normalize_Pathname
 439                             (Format_Pathname (Argument (J)),
 440                              Format_Pathname (Dir)),
 441                           UNIX));
 442                end if;
 443
 444                if J < Argument_Count then
 445                   Put (' ');
 446                end if;
 447             end loop;
 448          end;
 449
 450       elsif Cmd = "extend" then
 451          Check_Args (Argument_Count >= 2);
 452
 453          declare
 454             Dir : constant String := Argument (2);
 455
 456          begin
 457             --  Loop to remove quotes that may have been added around arguments
 458
 459             for J in 3 .. Argument_Count loop
 460                declare
 461                   Arg   : constant String := Argument (J);
 462                   First : Natural := Arg'First;
 463                   Last  : Natural := Arg'Last;
 464
 465                begin
 466                   if Arg (First) = '"' and then Arg (Last) = '"' then
 467                      First := First + 1;
 468                      Last  := Last - 1;
 469                   end if;
 470
 471                   if Is_Absolute_Path (Arg (First .. Last)) then
 472                      Extend (Format_Pathname (Arg (First .. Last), UNIX));
 473                   else
 474                      Extend
 475                        (Format_Pathname
 476                           (Normalize_Pathname
 477                              (Format_Pathname (Arg (First .. Last)),
 478                               Format_Pathname (Dir)),
 479                            UNIX));
 480                   end if;
 481
 482                   if J < Argument_Count then
 483                      Put (' ');
 484                   end if;
 485                end;
 486             end loop;
 487          end;
 488
 489       elsif Cmd = "deps" then
 490          Check_Args (Argument_Count in 3 .. 4);
 491          Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
 492
 493       elsif Cmd = "stamp" then
 494          Check_Args (Argument_Count = 3);
 495          Copy_Time_Stamp (Argument (2), Argument (3));
 496
 497       elsif Cmd = "prefix" then
 498
 499          --  Find the GNAT prefix. gprcmd is found in <prefix>/bin.
 500          --  So we find the full path of gprcmd, verify that it is in a
 501          --  subdirectory "bin", and return the <prefix> if it is the case.
 502          --  Otherwise, nothing is returned.
 503
 504          Find_Program_Name;
 505
 506          declare
 507             Path  : constant String_Access :=
 508                       Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
 509             Index : Natural;
 510
 511          begin
 512             if Path /= null then
 513                Index := Path'Last;
 514
 515                while Index >= Path'First + 4 loop
 516                   exit when Path (Index) = Directory_Separator;
 517                   Index := Index - 1;
 518                end loop;
 519
 520                if Index > Path'First + 5
 521                  and then Path (Index - 3 .. Index - 1) = "bin"
 522                  and then Path (Index - 4) = Directory_Separator
 523                then
 524                   --  We have found the <prefix>, return it
 525
 526                   Put (Path (Path'First .. Index - 5));
 527                end if;
 528             end if;
 529          end;
 530
 531       --  For "path" just add path separator after each directory argument
 532
 533       elsif Cmd = "path_sep" then
 534          Put (Path_Separator);
 535
 536       --  Check the linker options for relative paths. Insert the project
 537       --  base dir before relative paths.
 538
 539       elsif Cmd = "linkopts" then
 540          Check_Args (Argument_Count >= 2);
 541
 542          --  First argument is the base directory of the project file
 543
 544          declare
 545             Base_Dir : constant String := Argument (2) & '/';
 546          begin
 547             --  process the remainder of the arguments
 548
 549             for J in 3 .. Argument_Count loop
 550                declare
 551                   Arg : constant String := Argument (J);
 552                begin
 553                   --  If it is a switch other than a -L switch, just send back
 554                   --  the argument.
 555
 556                   if Arg (Arg'First) = '-' and then
 557                     (Arg'Length <= 2 or else Arg (Arg'First + 1) /= 'L')
 558                   then
 559                      Put (Arg);
 560
 561                   else
 562                      --  If it is a file, check if its path is relative, and
 563                      --  if it is relative, add <project base dir>/ in front.
 564                      --  Otherwise just send back the argument.
 565
 566                      if Arg'Length <= 2
 567                        or else Arg (Arg'First .. Arg'First + 1) /= "-L"
 568                      then
 569                         if not Is_Absolute_Path (Arg) then
 570                            Put (Base_Dir);
 571                         end if;
 572
 573                         Put (Arg);
 574
 575                      --  For -L switches, check if the path is relative and
 576                      --  proceed similarly.
 577
 578                      else
 579                         Put ("-L");
 580
 581                         if
 582                          not Is_Absolute_Path (Arg (Arg'First + 2 .. Arg'Last))
 583                         then
 584                            Put (Base_Dir);
 585                         end if;
 586
 587                         Put (Arg (Arg'First + 2 .. Arg'Last));
 588                      end if;
 589                   end if;
 590                end;
 591
 592                --  Insert a space between each processed argument
 593
 594                if J /= Argument_Count then
 595                   Put (' ');
 596                end if;
 597             end loop;
 598          end;
 599
 600       --  For "ignore" do nothing
 601
 602       elsif Cmd = "ignore" then
 603          null;
 604
 605       --  Unknown command
 606
 607       else
 608          Check_Args (False);
 609       end if;
 610    end;
 611 end Gprcmd;