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-2003 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
  42 with Gnatvsn;
  43 with Osint;   use Osint;
  44 with Namet;   use Namet;
  45
  46 with Ada.Characters.Handling;   use Ada.Characters.Handling;
  47 with Ada.Command_Line;          use Ada.Command_Line;
  48 with Ada.Text_IO;               use Ada.Text_IO;
  49 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  50 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  51 with GNAT.Regpat;               use GNAT.Regpat;
  52
  53
  54 procedure Gprcmd is
  55
  56    --  ??? comments are thin throughout this unit
  57
  58
  59    procedure Cat (File : String);
  60    --  Print the contents of file on standard output.
  61    --  If the file cannot be read, exit the process with an error code.
  62
  63    procedure Check_Args (Condition : Boolean);
  64    --  If Condition is false, print the usage, and exit the process.
  65
  66    procedure Deps (Objext : String; File : String; GCC : Boolean);
  67    --  Process $(CC) dependency file. If GCC is True, add a rule so that make
  68    --  will not complain when a file is removed/added. If GCC is False, add a
  69    --  rule to recompute the dependency file when needed
  70
  71    procedure Extend (Dir : String);
  72    --  If Dir ends with /**, Put all subdirs recursively on standard output,
  73    --  otherwise put Dir.
  74
  75    procedure Usage;
  76    --  Display the command line options and exit the process.
  77
  78    procedure Copy_Time_Stamp (From, To : String);
  79    --  Copy file time stamp from file From to file To.
  80
  81    ---------
  82    -- Cat --
  83    ---------
  84
  85    procedure Cat (File : String) is
  86       FD     : File_Descriptor;
  87       Buffer : String_Access;
  88       Length : Integer;
  89
  90    begin
  91       FD := Open_Read (File, Fmode => Binary);
  92
  93       if FD = Invalid_FD then
  94          OS_Exit (2);
  95       end if;
  96
  97       Length := Integer (File_Length (FD));
  98       Buffer := new String (1 .. Length);
  99       Length := Read (FD, Buffer.all'Address, Length);
 100       Close (FD);
 101       Put (Buffer.all);
 102       Free (Buffer);
 103    end Cat;
 104
 105    ----------------
 106    -- Check_Args --
 107    ----------------
 108
 109    procedure Check_Args (Condition : Boolean) is
 110    begin
 111       if not Condition then
 112          Usage;
 113       end if;
 114    end Check_Args;
 115
 116    ---------------------
 117    -- Copy_Time_Stamp --
 118    ---------------------
 119
 120    procedure Copy_Time_Stamp (From, To : String) is
 121       function Copy_Attributes
 122         (From, To : String;
 123          Mode     : Integer) return Integer;
 124       pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
 125       --  Mode = 0 - copy only time stamps.
 126       --  Mode = 1 - copy time stamps and read/write/execute attributes
 127
 128       FD : File_Descriptor;
 129
 130    begin
 131       if not Is_Regular_File (From) then
 132          return;
 133       end if;
 134
 135       FD := Create_File (To, Fmode => Binary);
 136
 137       if FD = Invalid_FD then
 138          OS_Exit (2);
 139       end if;
 140
 141       Close (FD);
 142
 143       if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
 144          OS_Exit (2);
 145       end if;
 146    end Copy_Time_Stamp;
 147
 148    ----------
 149    -- Deps --
 150    ----------
 151
 152    procedure Deps (Objext : String; File : String; GCC : Boolean) is
 153       Colon      : constant String := ':' & ASCII.LF;
 154       NL         : constant String := (1 => ASCII.LF);
 155       Base       : constant String := ' ' & Base_Name (File) & ": ";
 156       FD         : File_Descriptor;
 157       Buffer     : String_Access;
 158       Length     : Integer;
 159       Obj_Regexp : constant Pattern_Matcher :=
 160                      Compile ("^.*\" & Objext & ": ");
 161       Matched    : Match_Array (0 .. 0);
 162       Start      : Natural;
 163       First      : Natural;
 164       Last       : Natural;
 165
 166    begin
 167       FD := Open_Read_Write (File, Fmode => Binary);
 168
 169       if FD = Invalid_FD then
 170          return;
 171       end if;
 172
 173       Length := Integer (File_Length (FD));
 174       Buffer := new String (1 .. Length);
 175       Length := Read (FD, Buffer.all'Address, Length);
 176
 177       if GCC then
 178          Lseek (FD, 0, Seek_End);
 179       else
 180          Close (FD);
 181          FD := Create_File (File, Fmode => Binary);
 182       end if;
 183
 184       Start := Buffer'First;
 185
 186       while Start <= Buffer'Last loop
 187
 188          --  Parse Buffer line by line
 189
 190          while Start < Buffer'Last
 191            and then (Buffer (Start) = ASCII.CR
 192                      or else Buffer (Start) = ASCII.LF)
 193          loop
 194             Start := Start + 1;
 195          end loop;
 196
 197          Last := Start;
 198
 199          while Last < Buffer'Last
 200            and then Buffer (Last + 1) /= ASCII.CR
 201            and then Buffer (Last + 1) /= ASCII.LF
 202          loop
 203             Last := Last + 1;
 204          end loop;
 205
 206          Match (Obj_Regexp, Buffer (Start .. Last), Matched);
 207
 208          if GCC then
 209             if Matched (0) = No_Match then
 210                First := Start;
 211             else
 212                First := Matched (0).Last + 1;
 213             end if;
 214
 215             Length := Write (FD, Buffer (First)'Address, Last - First + 1);
 216
 217             if Start = Last or else Buffer (Last) = '\' then
 218                Length := Write (FD, NL (1)'Address, NL'Length);
 219             else
 220                Length := Write (FD, Colon (1)'Address, Colon'Length);
 221             end if;
 222
 223          else
 224             if Matched (0) = No_Match then
 225                First := Start;
 226             else
 227                Length :=
 228                  Write (FD, Buffer (Start)'Address,
 229                         Matched (0).Last - Start - 1);
 230                Length := Write (FD, Base (Base'First)'Address, Base'Length);
 231                First := Matched (0).Last + 1;
 232             end if;
 233
 234             Length := Write (FD, Buffer (First)'Address, Last - First + 1);
 235             Length := Write (FD, NL (1)'Address, NL'Length);
 236          end if;
 237
 238          Start := Last + 1;
 239       end loop;
 240
 241       Close (FD);
 242       Free (Buffer);
 243    end Deps;
 244
 245    ------------
 246    -- Extend --
 247    ------------
 248
 249    procedure Extend (Dir : String) is
 250
 251       procedure Recursive_Extend (D : String);
 252       --  Recursively display all subdirectories of D.
 253
 254       ----------------------
 255       -- Recursive_Extend --
 256       ----------------------
 257
 258       procedure Recursive_Extend (D : String) is
 259          Iter   : Dir_Type;
 260          Buffer : String (1 .. 8192);
 261          Last   : Natural;
 262
 263       begin
 264          Open (Iter, D);
 265
 266          loop
 267             Read (Iter, Buffer, Last);
 268
 269             exit when Last = 0;
 270
 271             if Buffer (1 .. Last) /= "."
 272               and then Buffer (1 .. Last) /= ".."
 273             then
 274                declare
 275                   Abs_Dir : constant String := D & Buffer (1 .. Last);
 276
 277                begin
 278                   if Is_Directory (Abs_Dir)
 279                     and then not Is_Symbolic_Link (Abs_Dir)
 280                   then
 281                      Put (' ' & Abs_Dir);
 282                      Recursive_Extend (Abs_Dir & '/');
 283                   end if;
 284                end;
 285             end if;
 286          end loop;
 287
 288          Close (Iter);
 289
 290       exception
 291          when Directory_Error =>
 292             null;
 293       end Recursive_Extend;
 294
 295    --  Start of processing for Extend
 296
 297    begin
 298       if Dir'Length < 3
 299         or else (Dir (Dir'Last - 2) /= '/'
 300                  and then Dir (Dir'Last - 2) /= Directory_Separator)
 301         or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
 302       then
 303          Put (Dir);
 304          return;
 305       end if;
 306
 307       declare
 308          D : constant String := Dir (Dir'First .. Dir'Last - 2);
 309       begin
 310          Put (D);
 311          Recursive_Extend (D);
 312       end;
 313    end Extend;
 314
 315    -----------
 316    -- Usage --
 317    -----------
 318
 319    procedure Usage is
 320    begin
 321       Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
 322       Put_Line (Standard_Error, "where cmd is one of the following commands:");
 323       Put_Line (Standard_Error, "  pwd         " &
 324                                 "display current directory");
 325       Put_Line (Standard_Error, "  to_lower    " &
 326                                 "display next argument in lower case");
 327       Put_Line (Standard_Error, "  to_absolute " &
 328                                 "convert pathnames to absolute " &
 329                                 "directories when needed");
 330       Put_Line (Standard_Error, "  cat         " &
 331                                 "dump contents of a given file");
 332       Put_Line (Standard_Error, "  extend      " &
 333                                 "handle recursive directories " &
 334                                 "(""/**"" notation)");
 335       Put_Line (Standard_Error, "  deps        " &
 336                                 "post process dependency makefiles");
 337       Put_Line (Standard_Error, "  stamp       " &
 338                                 "copy file time stamp from file1 to file2");
 339       OS_Exit (1);
 340    end Usage;
 341
 342 --  Start of processing for Gprcmd
 343
 344 begin
 345    Check_Args (Argument_Count > 0);
 346
 347    declare
 348       Cmd : constant String := Argument (1);
 349
 350    begin
 351       if Cmd = "-v" then
 352
 353          --  Should this be on Standard_Error ???
 354
 355          Put (Standard_Error, "GPRCMD ");
 356          Put (Standard_Error, Gnatvsn.Gnat_Version_String);
 357          Put_Line (Standard_Error,
 358                    " Copyright 2002-2003, Free Software Fundation, Inc.");
 359          Usage;
 360
 361       elsif Cmd = "pwd" then
 362          Put (Format_Pathname (Get_Current_Dir, UNIX));
 363
 364       elsif Cmd = "cat" then
 365          Check_Args (Argument_Count = 2);
 366          Cat (Argument (2));
 367
 368       elsif Cmd = "to_lower" then
 369          Check_Args (Argument_Count >= 2);
 370
 371          for J in 2 .. Argument_Count loop
 372             Put (To_Lower (Argument (J)));
 373
 374             if J < Argument_Count then
 375                Put (' ');
 376             end if;
 377          end loop;
 378
 379       elsif Cmd = "to_absolute" then
 380          Check_Args (Argument_Count > 2);
 381
 382          declare
 383             Dir : constant String := Argument (2);
 384
 385          begin
 386             for J in 3 .. Argument_Count loop
 387                if Is_Absolute_Path (Argument (J)) then
 388                   Put (Format_Pathname (Argument (J), UNIX));
 389                else
 390                   Put (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
 391                                         UNIX));
 392                end if;
 393
 394                if J < Argument_Count then
 395                   Put (' ');
 396                end if;
 397             end loop;
 398          end;
 399
 400       elsif Cmd = "extend" then
 401          Check_Args (Argument_Count >= 2);
 402
 403          declare
 404             Dir : constant String := Argument (2);
 405
 406          begin
 407             for J in 3 .. Argument_Count loop
 408                if Is_Absolute_Path (Argument (J)) then
 409                   Extend (Format_Pathname (Argument (J), UNIX));
 410                else
 411                   Extend
 412                     (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
 413                                       UNIX));
 414                end if;
 415
 416                if J < Argument_Count then
 417                   Put (' ');
 418                end if;
 419             end loop;
 420          end;
 421
 422       elsif Cmd = "deps" then
 423          Check_Args (Argument_Count in 3 .. 4);
 424          Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
 425
 426       elsif Cmd = "stamp" then
 427          Check_Args (Argument_Count = 3);
 428          Copy_Time_Stamp (Argument (2), Argument (3));
 429
 430       elsif Cmd = "prefix" then
 431
 432          --  Find the GNAT prefix. gprcmd is found in <prefix>/bin.
 433          --  So we find the full path of gprcmd, verify that it is in a
 434          --  subdirectory "bin", and return the <prefix> if it is the case.
 435          --  Otherwise, nothing is returned.
 436
 437          Find_Program_Name;
 438
 439          declare
 440             Path : String_Access :=
 441                      Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
 442             Index : Natural;
 443
 444          begin
 445             if Path /= null then
 446                Index := Path'Last;
 447
 448                while Index >= Path'First + 4 loop
 449                   exit when Path (Index) = Directory_Separator;
 450                   Index := Index - 1;
 451                end loop;
 452
 453                if Index > Path'First + 5
 454                  and then Path (Index - 3 .. Index - 1) = "bin"
 455                  and then Path (Index - 4) = Directory_Separator
 456                then
 457                   --  We have found the <prefix>, return it.
 458
 459                   Put (Path (Path'First .. Index - 5));
 460                end if;
 461             end if;
 462          end;
 463       end if;
 464    end;
 465 end Gprcmd;