------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G P R C M D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- A utility used by Makefile.generic to handle multi-language builds.
-- gprcmd provides a set of commands so that the makefiles do not need
-- to depend on unix utilities not available on all targets.
-- The list of commands recognized by gprcmd are:
-- pwd display current directory
-- to_lower display next argument in lower case
-- to_absolute convert pathnames to absolute directories when needed
-- cat dump contents of a given file
-- extend handle recursive directories ("/**" notation)
-- deps post process dependency makefiles
-- stamp copy file time stamp from file1 to file2
-- prefix get the prefix of the GNAT installation
with Gnatvsn;
with Osint; use Osint;
with Namet; use Namet;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Regpat; use GNAT.Regpat;
procedure Gprcmd is
-- ??? comments are thin throughout this unit
procedure Cat (File : String);
-- Print the contents of file on standard output.
-- If the file cannot be read, exit the process with an error code.
procedure Check_Args (Condition : Boolean);
-- If Condition is false, print the usage, and exit the process.
procedure Deps (Objext : String; File : String; GCC : Boolean);
-- Process $(CC) dependency file. If GCC is True, add a rule so that make
-- will not complain when a file is removed/added. If GCC is False, add a
-- rule to recompute the dependency file when needed
procedure Extend (Dir : String);
-- If Dir ends with /**, Put all subdirs recursively on standard output,
-- otherwise put Dir.
procedure Usage;
-- Display the command line options and exit the process.
procedure Copy_Time_Stamp (From, To : String);
-- Copy file time stamp from file From to file To.
---------
-- Cat --
---------
procedure Cat (File : String) is
FD : File_Descriptor;
Buffer : String_Access;
Length : Integer;
begin
FD := Open_Read (File, Fmode => Binary);
if FD = Invalid_FD then
OS_Exit (2);
end if;
Length := Integer (File_Length (FD));
Buffer := new String (1 .. Length);
Length := Read (FD, Buffer.all'Address, Length);
Close (FD);
Put (Buffer.all);
Free (Buffer);
end Cat;
----------------
-- Check_Args --
----------------
procedure Check_Args (Condition : Boolean) is
begin
if not Condition then
Usage;
end if;
end Check_Args;
---------------------
-- Copy_Time_Stamp --
---------------------
procedure Copy_Time_Stamp (From, To : String) is
function Copy_Attributes
(From, To : String;
Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
FD : File_Descriptor;
begin
if not Is_Regular_File (From) then
return;
end if;
FD := Create_File (To, Fmode => Binary);
if FD = Invalid_FD then
OS_Exit (2);
end if;
Close (FD);
if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
OS_Exit (2);
end if;
end Copy_Time_Stamp;
----------
-- Deps --
----------
procedure Deps (Objext : String; File : String; GCC : Boolean) is
Colon : constant String := ':' & ASCII.LF;
NL : constant String := (1 => ASCII.LF);
Base : constant String := ' ' & Base_Name (File) & ": ";
FD : File_Descriptor;
Buffer : String_Access;
Length : Integer;
Obj_Regexp : constant Pattern_Matcher :=
Compile ("^.*\" & Objext & ": ");
Matched : Match_Array (0 .. 0);
Start : Natural;
First : Natural;
Last : Natural;
begin
FD := Open_Read_Write (File, Fmode => Binary);
if FD = Invalid_FD then
return;
end if;
Length := Integer (File_Length (FD));
Buffer := new String (1 .. Length);
Length := Read (FD, Buffer.all'Address, Length);
if GCC then
Lseek (FD, 0, Seek_End);
else
Close (FD);
FD := Create_File (File, Fmode => Binary);
end if;
Start := Buffer'First;
while Start <= Buffer'Last loop
-- Parse Buffer line by line
while Start < Buffer'Last
and then (Buffer (Start) = ASCII.CR
or else Buffer (Start) = ASCII.LF)
loop
Start := Start + 1;
end loop;
Last := Start;
while Last < Buffer'Last
and then Buffer (Last + 1) /= ASCII.CR
and then Buffer (Last + 1) /= ASCII.LF
loop
Last := Last + 1;
end loop;
Match (Obj_Regexp, Buffer (Start .. Last), Matched);
if GCC then
if Matched (0) = No_Match then
First := Start;
else
First := Matched (0).Last + 1;
end if;
Length := Write (FD, Buffer (First)'Address, Last - First + 1);
if Start = Last or else Buffer (Last) = '\' then
Length := Write (FD, NL (1)'Address, NL'Length);
else
Length := Write (FD, Colon (1)'Address, Colon'Length);
end if;
else
if Matched (0) = No_Match then
First := Start;
else
Length :=
Write (FD, Buffer (Start)'Address,
Matched (0).Last - Start - 1);
Length := Write (FD, Base (Base'First)'Address, Base'Length);
First := Matched (0).Last + 1;
end if;
Length := Write (FD, Buffer (First)'Address, Last - First + 1);
Length := Write (FD, NL (1)'Address, NL'Length);
end if;
Start := Last + 1;
end loop;
Close (FD);
Free (Buffer);
end Deps;
------------
-- Extend --
------------
procedure Extend (Dir : String) is
procedure Recursive_Extend (D : String);
-- Recursively display all subdirectories of D.
----------------------
-- Recursive_Extend --
----------------------
procedure Recursive_Extend (D : String) is
Iter : Dir_Type;
Buffer : String (1 .. 8192);
Last : Natural;
begin
Open (Iter, D);
loop
Read (Iter, Buffer, Last);
exit when Last = 0;
if Buffer (1 .. Last) /= "."
and then Buffer (1 .. Last) /= ".."
then
declare
Abs_Dir : constant String := D & Buffer (1 .. Last);
begin
if Is_Directory (Abs_Dir)
and then not Is_Symbolic_Link (Abs_Dir)
then
Put (' ' & Abs_Dir);
Recursive_Extend (Abs_Dir & '/');
end if;
end;
end if;
end loop;
Close (Iter);
exception
when Directory_Error =>
null;
end Recursive_Extend;
-- Start of processing for Extend
begin
if Dir'Length < 3
or else (Dir (Dir'Last - 2) /= '/'
and then Dir (Dir'Last - 2) /= Directory_Separator)
or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
then
Put (Dir);
return;
end if;
declare
D : constant String := Dir (Dir'First .. Dir'Last - 2);
begin
Put (D);
Recursive_Extend (D);
end;
end Extend;
-----------
-- Usage --
-----------
procedure Usage is
begin
Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
Put_Line (Standard_Error, "where cmd is one of the following commands:");
Put_Line (Standard_Error, " pwd " &
"display current directory");
Put_Line (Standard_Error, " to_lower " &
"display next argument in lower case");
Put_Line (Standard_Error, " to_absolute " &
"convert pathnames to absolute " &
"directories when needed");
Put_Line (Standard_Error, " cat " &
"dump contents of a given file");
Put_Line (Standard_Error, " extend " &
"handle recursive directories " &
"(""/**"" notation)");
Put_Line (Standard_Error, " deps " &
"post process dependency makefiles");
Put_Line (Standard_Error, " stamp " &
"copy file time stamp from file1 to file2");
OS_Exit (1);
end Usage;
-- Start of processing for Gprcmd
begin
Check_Args (Argument_Count > 0);
declare
Cmd : constant String := Argument (1);
begin
if Cmd = "-v" then
-- Should this be on Standard_Error ???
Put (Standard_Error, "GPRCMD ");
Put (Standard_Error, Gnatvsn.Gnat_Version_String);
Put_Line (Standard_Error,
" Copyright 2002-2003, Free Software Fundation, Inc.");
Usage;
elsif Cmd = "pwd" then
Put (Format_Pathname (Get_Current_Dir, UNIX));
elsif Cmd = "cat" then
Check_Args (Argument_Count = 2);
Cat (Argument (2));
elsif Cmd = "to_lower" then
Check_Args (Argument_Count >= 2);
for J in 2 .. Argument_Count loop
Put (To_Lower (Argument (J)));
if J < Argument_Count then
Put (' ');
end if;
end loop;
elsif Cmd = "to_absolute" then
Check_Args (Argument_Count > 2);
declare
Dir : constant String := Argument (2);
begin
for J in 3 .. Argument_Count loop
if Is_Absolute_Path (Argument (J)) then
Put (Format_Pathname (Argument (J), UNIX));
else
Put (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
UNIX));
end if;
if J < Argument_Count then
Put (' ');
end if;
end loop;
end;
elsif Cmd = "extend" then
Check_Args (Argument_Count >= 2);
declare
Dir : constant String := Argument (2);
begin
for J in 3 .. Argument_Count loop
if Is_Absolute_Path (Argument (J)) then
Extend (Format_Pathname (Argument (J), UNIX));
else
Extend
(Format_Pathname (Normalize_Pathname (Argument (J), Dir),
UNIX));
end if;
if J < Argument_Count then
Put (' ');
end if;
end loop;
end;
elsif Cmd = "deps" then
Check_Args (Argument_Count in 3 .. 4);
Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
elsif Cmd = "stamp" then
Check_Args (Argument_Count = 3);
Copy_Time_Stamp (Argument (2), Argument (3));
elsif Cmd = "prefix" then
-- Find the GNAT prefix. gprcmd is found in <prefix>/bin.
-- So we find the full path of gprcmd, verify that it is in a
-- subdirectory "bin", and return the <prefix> if it is the case.
-- Otherwise, nothing is returned.
Find_Program_Name;
declare
Path : String_Access :=
Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len));
Index : Natural;
begin
if Path /= null then
Index := Path'Last;
while Index >= Path'First + 4 loop
exit when Path (Index) = Directory_Separator;
Index := Index - 1;
end loop;
if Index > Path'First + 5
and then Path (Index - 3 .. Index - 1) = "bin"
and then Path (Index - 4) = Directory_Separator
then
-- We have found the <prefix>, return it.
Put (Path (Path'First .. Index - 5));
end if;
end if;
end;
end if;
end;
end Gprcmd;