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