------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . C O M M A N D _ L I N E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2021, 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 3, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings.Unbounded;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Unchecked_Deallocation;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
package body GNAT.Command_Line is
-- General note: this entire body could use much more commenting. There
-- are large sections of uncommented code throughout, and many formal
-- parameters of local subprograms are not documented at all ???
package CL renames Ada.Command_Line;
type Switch_Parameter_Type is
(Parameter_None,
Parameter_With_Optional_Space, -- ':' in getopt
Parameter_With_Space_Or_Equal, -- '=' in getopt
Parameter_No_Space, -- '!' in getopt
Parameter_Optional); -- '?' in getopt
procedure Set_Parameter
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
Last : Natural;
Extra : Character := ASCII.NUL);
pragma Inline (Set_Parameter);
-- Set the parameter that will be returned by Parameter below
--
-- Extra is a character that needs to be added when reporting Full_Switch.
-- (it will in general be the switch character, for instance '-').
-- Otherwise, Full_Switch will report 'f' instead of '-f'. In particular,
-- it needs to be set when reporting an invalid switch or handling '*'.
--
-- Parameters need to be defined ???
function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean;
-- Go to the next argument on the command line. If we are at the end of
-- the current section, we want to make sure there is no other identical
-- section on the command line (there might be multiple instances of
-- -largs). Returns True iff there is another argument.
function Get_File_Names_Case_Sensitive return Integer;
pragma Import (C, Get_File_Names_Case_Sensitive,
"__gnat_get_file_names_case_sensitive");
File_Names_Case_Sensitive : constant Boolean :=
Get_File_Names_Case_Sensitive /= 0;
procedure Canonical_Case_File_Name (S : in out String);
-- Given a file name, converts it to canonical case form. For systems where
-- file names are case sensitive, this procedure has no effect. If file
-- names are not case sensitive (i.e. for example if you have the file
-- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call
-- converts the given string to canonical all lower case form, so that two
-- file names compare equal if they refer to the same file.
procedure Internal_Initialize_Option_Scan
(Parser : Opt_Parser;
Switch_Char : Character;
Stop_At_First_Non_Switch : Boolean;
Section_Delimiters : String);
-- Initialize Parser, which must have been allocated already
function Argument (Parser : Opt_Parser; Index : Integer) return String;
-- Return the index-th command line argument
procedure Find_Longest_Matching_Switch
(Switches : String;
Arg : String;
Index_In_Switches : out Integer;
Switch_Length : out Integer;
Param : out Switch_Parameter_Type);
-- Return the Longest switch from Switches that at least partially matches
-- Arg. Index_In_Switches is set to 0 if none matches. What are other
-- parameters??? in particular Param is not always set???
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Argument_List, Argument_List_Access);
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Command_Line_Configuration_Record, Command_Line_Configuration);
procedure Remove (Line : in out Argument_List_Access; Index : Integer);
-- Remove a specific element from Line
procedure Add
(Line : in out Argument_List_Access;
Str : String_Access;
Before : Boolean := False);
-- Add a new element to Line. If Before is True, the item is inserted at
-- the beginning, else it is appended.
procedure Add
(Config : in out Command_Line_Configuration;
Switch : Switch_Definition);
procedure Add
(Def : in out Alias_Definitions_List;
Alias : Alias_Definition);
-- Add a new element to Def
procedure Initialize_Switch_Def
(Def : out Switch_Definition;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Argument : String := "ARG");
-- Initialize [Def] with the contents of the other parameters.
-- This also checks consistency of the switch parameters, and will raise
-- Invalid_Switch if they do not match.
procedure Decompose_Switch
(Switch : String;
Parameter_Type : out Switch_Parameter_Type;
Switch_Last : out Integer);
-- Given a switch definition ("name:" for instance), extracts the type of
-- parameter that is expected, and the name of the switch
function Can_Have_Parameter (S : String) return Boolean;
-- True if S can have a parameter
function Require_Parameter (S : String) return Boolean;
-- True if S requires a parameter
function Actual_Switch (S : String) return String;
-- Remove any possible trailing '!', ':', '?' and '='
generic
with procedure Callback
(Simple_Switch : String;
Separator : String;
Parameter : String;
Index : Integer); -- Index in Config.Switches, or -1
procedure For_Each_Simple_Switch
(Config : Command_Line_Configuration;
Section : String;
Switch : String;
Parameter : String := "";
Unalias : Boolean := True);
-- Breaks Switch into as simple switches as possible (expanding aliases and
-- ungrouping common prefixes when possible), and call Callback for each of
-- these.
procedure Sort_Sections
(Line : not null GNAT.OS_Lib.Argument_List_Access;
Sections : GNAT.OS_Lib.Argument_List_Access;
Params : GNAT.OS_Lib.Argument_List_Access);
-- Reorder the command line switches so that the switches belonging to a
-- section are grouped together.
procedure Group_Switches
(Cmd : Command_Line;
Result : Argument_List_Access;
Sections : Argument_List_Access;
Params : Argument_List_Access);
-- Group switches with common prefixes whenever possible. Once they have
-- been grouped, we also check items for possible aliasing.
procedure Alias_Switches
(Cmd : Command_Line;
Result : Argument_List_Access;
Params : Argument_List_Access);
-- When possible, replace one or more switches by an alias, i.e. a shorter
-- version.
function Looking_At
(Type_Str : String;
Index : Natural;
Substring : String) return Boolean;
-- Return True if the characters starting at Index in Type_Str are
-- equivalent to Substring.
generic
with function Callback (S : String; Index : Integer) return Boolean;
procedure Foreach_Switch
(Config : Command_Line_Configuration;
Section : String);
-- Iterate over all switches defined in Config, for a specific section.
-- Index is set to the index in Config.Switches. Stop iterating when
-- Callback returns False.
--------------
-- Argument --
--------------
function Argument (Parser : Opt_Parser; Index : Integer) return String is
begin
if Parser.Arguments /= null then
return Parser.Arguments (Index + Parser.Arguments'First - 1).all;
else
return CL.Argument (Index);
end if;
end Argument;
------------------------------
-- Canonical_Case_File_Name --
------------------------------
procedure Canonical_Case_File_Name (S : in out String) is
begin
if not File_Names_Case_Sensitive then
for J in S'Range loop
if S (J) in 'A' .. 'Z' then
S (J) := Character'Val
(Character'Pos (S (J)) +
(Character'Pos ('a') - Character'Pos ('A')));
end if;
end loop;
end if;
end Canonical_Case_File_Name;
---------------
-- Expansion --
---------------
function Expansion (Iterator : Expansion_Iterator) return String is
type Pointer is access all Expansion_Iterator;
It : constant Pointer := Iterator'Unrestricted_Access;
S : String (1 .. 1024);
Last : Natural;
Current : Depth := It.Current_Depth;
NL : Positive;
begin
-- It is assumed that a directory is opened at the current level.
-- Otherwise GNAT.Directory_Operations.Directory_Error will be raised
-- at the first call to Read.
loop
Read (It.Levels (Current).Dir, S, Last);
-- If we have exhausted the directory, close it and go back one level
if Last = 0 then
Close (It.Levels (Current).Dir);
-- If we are at level 1, we are finished; return an empty string
if Current = 1 then
return String'(1 .. 0 => ' ');
-- Otherwise continue with the directory at the previous level
else
Current := Current - 1;
It.Current_Depth := Current;
end if;
-- If this is a directory, that is neither "." or "..", attempt to
-- go to the next level.
elsif Is_Directory
(It.Dir_Name (1 .. It.Levels (Current).Name_Last) &
S (1 .. Last))
and then S (1 .. Last) /= "."
and then S (1 .. Last) /= ".."
then
-- We can go to the next level only if we have not reached the
-- maximum depth,
if Current < It.Maximum_Depth then
NL := It.Levels (Current).Name_Last;
-- And if relative path of this new directory is not too long
if NL + Last + 1 < Max_Path_Length then
Current := Current + 1;
It.Current_Depth := Current;
It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last);
NL := NL + Last + 1;
It.Dir_Name (NL) := Directory_Separator;
It.Levels (Current).Name_Last := NL;
Canonical_Case_File_Name (It.Dir_Name (1 .. NL));
-- Open the new directory, and read from it
GNAT.Directory_Operations.Open
(It.Levels (Current).Dir, It.Dir_Name (1 .. NL));
end if;
end if;
end if;
-- Check the relative path against the pattern
-- Note that we try to match also against directory names, since
-- clients of this function may expect to retrieve directories.
declare
Name : String :=
It.Dir_Name (It.Start .. It.Levels (Current).Name_Last)
& S (1 .. Last);
begin
Canonical_Case_File_Name (Name);
-- If it matches return the relative path
if GNAT.Regexp.Match (Name, Iterator.Regexp) then
return Name;
end if;
end;
end loop;
end Expansion;
---------------------
-- Current_Section --
---------------------
function Current_Section
(Parser : Opt_Parser := Command_Line_Parser) return String
is
begin
if Parser.Current_Section = 1 then
return "";
end if;
for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1,
Parser.Section'Last)
loop
if Parser.Section (Index) = 0 then
return Argument (Parser, Index);
end if;
end loop;
return "";
end Current_Section;
-----------------
-- Full_Switch --
-----------------
function Full_Switch
(Parser : Opt_Parser := Command_Line_Parser) return String
is
begin
if Parser.The_Switch.Extra = ASCII.NUL then
return Argument (Parser, Parser.The_Switch.Arg_Num)
(Parser.The_Switch.First .. Parser.The_Switch.Last);
else
return Parser.The_Switch.Extra
& Argument (Parser, Parser.The_Switch.Arg_Num)
(Parser.The_Switch.First .. Parser.The_Switch.Last);
end if;
end Full_Switch;
------------------
-- Get_Argument --
------------------
function Get_Argument
(Do_Expansion : Boolean := False;
Parser : Opt_Parser := Command_Line_Parser) return String
is
End_Of_Args : Boolean;
begin
return Get_Argument (Do_Expansion, Parser, End_Of_Args);
end Get_Argument;
------------------
-- Get_Argument --
------------------
function Get_Argument
(Do_Expansion : Boolean := False;
Parser : Opt_Parser := Command_Line_Parser;
End_Of_Arguments : out Boolean) return String is
begin
End_Of_Arguments := False;
if Parser.In_Expansion then
declare
S : constant String := Expansion (Parser.Expansion_It);
begin
if S'Length /= 0 then
return S;
else
Parser.In_Expansion := False;
end if;
end;
end if;
if Parser.Current_Argument > Parser.Arg_Count then
-- If this is the first time this function is called
if Parser.Current_Index = 1 then
Parser.Current_Argument := 1;
while Parser.Current_Argument <= Parser.Arg_Count
and then Parser.Section (Parser.Current_Argument) /=
Parser.Current_Section
loop
Parser.Current_Argument := Parser.Current_Argument + 1;
end loop;
else
End_Of_Arguments := True;
return String'(1 .. 0 => ' ');
end if;
elsif Parser.Section (Parser.Current_Argument) = 0 then
while Parser.Current_Argument <= Parser.Arg_Count
and then Parser.Section (Parser.Current_Argument) /=
Parser.Current_Section
loop
Parser.Current_Argument := Parser.Current_Argument + 1;
end loop;
end if;
Parser.Current_Index := Integer'Last;
while Parser.Current_Argument <= Parser.Arg_Count
and then Parser.Is_Switch (Parser.Current_Argument)
loop
Parser.Current_Argument := Parser.Current_Argument + 1;
end loop;
if Parser.Current_Argument > Parser.Arg_Count then
End_Of_Arguments := True;
return String'(1 .. 0 => ' ');
elsif Parser.Section (Parser.Current_Argument) = 0 then
return Get_Argument (Do_Expansion, Parser, End_Of_Arguments);
end if;
Parser.Current_Argument := Parser.Current_Argument + 1;
-- Could it be a file name with wildcards to expand?
if Do_Expansion then
declare
Arg : constant String :=
Argument (Parser, Parser.Current_Argument - 1);
begin
for Index in Arg'Range loop
if Arg (Index) in '*' | '?' | '[' then
Parser.In_Expansion := True;
Start_Expansion (Parser.Expansion_It, Arg);
return Get_Argument (Do_Expansion, Parser, End_Of_Arguments);
end if;
end loop;
end;
end if;
return Argument (Parser, Parser.Current_Argument - 1);
end Get_Argument;
----------------------
-- Decompose_Switch --
----------------------
procedure Decompose_Switch
(Switch : String;
Parameter_Type : out Switch_Parameter_Type;
Switch_Last : out Integer)
is
begin
if Switch = "" then
Parameter_Type := Parameter_None;
Switch_Last := Switch'Last;
return;
end if;
case Switch (Switch'Last) is
when ':' =>
Parameter_Type := Parameter_With_Optional_Space;
Switch_Last := Switch'Last - 1;
when '=' =>
Parameter_Type := Parameter_With_Space_Or_Equal;
Switch_Last := Switch'Last - 1;
when '!' =>
Parameter_Type := Parameter_No_Space;
Switch_Last := Switch'Last - 1;
when '?' =>
Parameter_Type := Parameter_Optional;
Switch_Last := Switch'Last - 1;
when others =>
Parameter_Type := Parameter_None;
Switch_Last := Switch'Last;
end case;
end Decompose_Switch;
----------------------------------
-- Find_Longest_Matching_Switch --
----------------------------------
procedure Find_Longest_Matching_Switch
(Switches : String;
Arg : String;
Index_In_Switches : out Integer;
Switch_Length : out Integer;
Param : out Switch_Parameter_Type)
is
Index : Natural;
Length : Natural := 1;
Last : Natural;
P : Switch_Parameter_Type;
begin
Param := Parameter_None;
Index_In_Switches := 0;
Switch_Length := 0;
-- Remove all leading spaces first to make sure that Index points
-- at the start of the first switch.
Index := Switches'First;
while Index <= Switches'Last and then Switches (Index) = ' ' loop
Index := Index + 1;
end loop;
while Index <= Switches'Last loop
-- Search the length of the parameter at this position in Switches
Length := Index;
while Length <= Switches'Last
and then Switches (Length) /= ' '
loop
Length := Length + 1;
end loop;
-- Length now marks the separator after the current switch. Last will
-- mark the last character of the name of the switch.
if Length = Index + 1 then
P := Parameter_None;
Last := Index;
else
Decompose_Switch (Switches (Index .. Length - 1), P, Last);
end if;
-- If it is the one we searched, it may be a candidate
if Arg'First + Last - Index <= Arg'Last
and then Switches (Index .. Last) =
Arg (Arg'First .. Arg'First + Last - Index)
and then Last - Index + 1 > Switch_Length
and then
(P /= Parameter_With_Space_Or_Equal
or else Arg'Last = Arg'First + Last - Index
or else Arg (Arg'First + Last - Index + 1) = '=')
then
Param := P;
Index_In_Switches := Index;
Switch_Length := Last - Index + 1;
end if;
-- Look for the next switch in Switches
while Index <= Switches'Last
and then Switches (Index) /= ' '
loop
Index := Index + 1;
end loop;
Index := Index + 1;
end loop;
end Find_Longest_Matching_Switch;
------------
-- Getopt --
------------
function Getopt
(Switches : String;
Concatenate : Boolean := True;
Parser : Opt_Parser := Command_Line_Parser) return Character
is
Dummy : Boolean;
begin
<>
-- If we have finished parsing the current command line item (there
-- might be multiple switches in a single item), then go to the next
-- element.
if Parser.Current_Argument > Parser.Arg_Count
or else (Parser.Current_Index >
Argument (Parser, Parser.Current_Argument)'Last
and then not Goto_Next_Argument_In_Section (Parser))
then
return ASCII.NUL;
end if;
-- By default, the switch will not have a parameter
Parser.The_Parameter :=
(Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL);
Parser.The_Separator := ASCII.NUL;
declare
Arg : constant String :=
Argument (Parser, Parser.Current_Argument);
Index_Switches : Natural := 0;
Max_Length : Natural := 0;
End_Index : Natural;
Param : Switch_Parameter_Type;
begin
-- If we are on a new item, test if this might be a switch
if Parser.Current_Index = Arg'First then
if Arg = "" or else Arg (Arg'First) /= Parser.Switch_Character then
-- If it isn't a switch, return it immediately. We also know it
-- isn't the parameter to a previous switch, since that has
-- already been handled.
if Switches (Switches'First) = '*' then
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Arg'First,
Last => Arg'Last);
Parser.Is_Switch (Parser.Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section (Parser);
return '*';
end if;
if Parser.Stop_At_First then
Parser.Current_Argument := Positive'Last;
return ASCII.NUL;
elsif not Goto_Next_Argument_In_Section (Parser) then
return ASCII.NUL;
else
-- Recurse to get the next switch on the command line
goto Restart;
end if;
end if;
-- We are on the first character of a new command line argument,
-- which starts with Switch_Character. Further analysis is needed.
Parser.Current_Index := Parser.Current_Index + 1;
Parser.Is_Switch (Parser.Current_Argument) := True;
end if;
Find_Longest_Matching_Switch
(Switches => Switches,
Arg => Arg (Parser.Current_Index .. Arg'Last),
Index_In_Switches => Index_Switches,
Switch_Length => Max_Length,
Param => Param);
-- If switch is not accepted, it is either invalid or is returned
-- in the context of '*'.
if Index_Switches = 0 then
-- Find the current switch that we did not recognize. This is in
-- fact difficult because Getopt does not know explicitly about
-- short and long switches. Ideally, we would want the following
-- behavior:
-- * for short switches, with Concatenate:
-- if -a is not recognized, and the command line has -daf
-- we should report the invalid switch as "-a".
-- * for short switches, wihtout Concatenate:
-- we should report the invalid switch as "-daf".
-- * for long switches:
-- if the commadn line is "--long" we should report --long
-- as unrecongized.
-- Unfortunately, the fact that long switches start with a
-- duplicate switch character is just a convention (so we could
-- have a long switch "-long" for instance). We'll still rely on
-- this convention here to try and get as helpful an error message
-- as possible.
-- Long switch case (starting with double switch character)
if Arg (Arg'First + 1) = Parser.Switch_Character then
End_Index := Arg'Last;
-- Short switch case
else
End_Index :=
(if Concatenate then Parser.Current_Index else Arg'Last);
end if;
if Switches /= "" and then Switches (Switches'First) = '*' then
-- Always prepend the switch character, so that users know
-- that this comes from a switch on the command line. This
-- is especially important when Concatenate is False, since
-- otherwise the current argument first character is lost.
if Parser.Section (Parser.Current_Argument) = 0 then
-- A section transition should not be returned to the user
Dummy := Goto_Next_Argument_In_Section (Parser);
goto Restart;
else
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
Last => Arg'Last,
Extra => Parser.Switch_Character);
Parser.Is_Switch (Parser.Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section (Parser);
return '*';
end if;
end if;
if Parser.Current_Index = Arg'First then
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
Last => End_Index);
else
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
Last => End_Index,
Extra => Parser.Switch_Character);
end if;
Parser.Current_Index := End_Index + 1;
raise Invalid_Switch with
"Unrecognized option '" & Full_Switch (Parser) & ''';
end if;
End_Index := Parser.Current_Index + Max_Length - 1;
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
Last => End_Index);
case Param is
when Parameter_With_Optional_Space =>
if End_Index < Arg'Last then
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
Dummy := Goto_Next_Argument_In_Section (Parser);
elsif Parser.Current_Argument < Parser.Arg_Count
and then Parser.Section (Parser.Current_Argument + 1) /= 0
then
Parser.Current_Argument := Parser.Current_Argument + 1;
Parser.The_Separator := ' ';
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => Argument (Parser, Parser.Current_Argument)'First,
Last => Argument (Parser, Parser.Current_Argument)'Last);
Parser.Is_Switch (Parser.Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section (Parser);
else
Parser.Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
when Parameter_With_Space_Or_Equal =>
-- If the switch is of the form =xxx
if End_Index < Arg'Last then
if Arg (End_Index + 1) = '='
and then End_Index + 1 < Arg'Last
then
Parser.The_Separator := '=';
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => End_Index + 2,
Last => Arg'Last);
Dummy := Goto_Next_Argument_In_Section (Parser);
else
Parser.Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
-- Case of switch of the form xxx
elsif Parser.Current_Argument < Parser.Arg_Count
and then Parser.Section (Parser.Current_Argument + 1) /= 0
then
Parser.Current_Argument := Parser.Current_Argument + 1;
Parser.The_Separator := ' ';
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => Argument (Parser, Parser.Current_Argument)'First,
Last => Argument (Parser, Parser.Current_Argument)'Last);
Parser.Is_Switch (Parser.Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section (Parser);
else
Parser.Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
when Parameter_No_Space =>
if End_Index < Arg'Last then
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
Dummy := Goto_Next_Argument_In_Section (Parser);
else
Parser.Current_Index := End_Index + 1;
raise Invalid_Parameter;
end if;
when Parameter_Optional =>
if End_Index < Arg'Last then
Set_Parameter
(Parser.The_Parameter,
Arg_Num => Parser.Current_Argument,
First => End_Index + 1,
Last => Arg'Last);
end if;
Dummy := Goto_Next_Argument_In_Section (Parser);
when Parameter_None =>
if Concatenate or else End_Index = Arg'Last then
Parser.Current_Index := End_Index + 1;
else
-- If Concatenate is False and the full argument is not
-- recognized as a switch, this is an invalid switch.
if Switches (Switches'First) = '*' then
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Arg'First,
Last => Arg'Last);
Parser.Is_Switch (Parser.Current_Argument) := True;
Dummy := Goto_Next_Argument_In_Section (Parser);
return '*';
end if;
Set_Parameter
(Parser.The_Switch,
Arg_Num => Parser.Current_Argument,
First => Parser.Current_Index,
Last => Arg'Last,
Extra => Parser.Switch_Character);
Parser.Current_Index := Arg'Last + 1;
raise Invalid_Switch with
"Unrecognized option '" & Full_Switch (Parser) & ''';
end if;
end case;
return Switches (Index_Switches);
end;
end Getopt;
-----------------------------------
-- Goto_Next_Argument_In_Section --
-----------------------------------
function Goto_Next_Argument_In_Section
(Parser : Opt_Parser) return Boolean
is
begin
Parser.Current_Argument := Parser.Current_Argument + 1;
if Parser.Current_Argument > Parser.Arg_Count
or else Parser.Section (Parser.Current_Argument) = 0
then
loop
Parser.Current_Argument := Parser.Current_Argument + 1;
if Parser.Current_Argument > Parser.Arg_Count then
Parser.Current_Index := 1;
return False;
end if;
exit when Parser.Section (Parser.Current_Argument) =
Parser.Current_Section;
end loop;
end if;
Parser.Current_Index :=
Argument (Parser, Parser.Current_Argument)'First;
return True;
end Goto_Next_Argument_In_Section;
------------------
-- Goto_Section --
------------------
procedure Goto_Section
(Name : String := "";
Parser : Opt_Parser := Command_Line_Parser)
is
Index : Integer;
begin
Parser.In_Expansion := False;
if Name = "" then
Parser.Current_Argument := 1;
Parser.Current_Index := 1;
Parser.Current_Section := 1;
return;
end if;
Index := 1;
while Index <= Parser.Arg_Count loop
if Parser.Section (Index) = 0
and then Argument (Parser, Index) = Parser.Switch_Character & Name
then
Parser.Current_Argument := Index + 1;
Parser.Current_Index := 1;
if Parser.Current_Argument <= Parser.Arg_Count then
Parser.Current_Section :=
Parser.Section (Parser.Current_Argument);
end if;
-- Exit from loop if we have the start of another section
if Index = Parser.Section'Last
or else Parser.Section (Index + 1) /= 0
then
return;
end if;
end if;
Index := Index + 1;
end loop;
Parser.Current_Argument := Positive'Last;
Parser.Current_Index := 2; -- so that Get_Argument returns nothing
end Goto_Section;
----------------------------
-- Initialize_Option_Scan --
----------------------------
procedure Initialize_Option_Scan
(Switch_Char : Character := '-';
Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := "")
is
begin
Internal_Initialize_Option_Scan
(Parser => Command_Line_Parser,
Switch_Char => Switch_Char,
Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
Section_Delimiters => Section_Delimiters);
end Initialize_Option_Scan;
----------------------------
-- Initialize_Option_Scan --
----------------------------
procedure Initialize_Option_Scan
(Parser : out Opt_Parser;
Command_Line : GNAT.OS_Lib.Argument_List_Access;
Switch_Char : Character := '-';
Stop_At_First_Non_Switch : Boolean := False;
Section_Delimiters : String := "")
is
begin
Free (Parser);
if Command_Line = null then
Parser := new Opt_Parser_Data (CL.Argument_Count);
Internal_Initialize_Option_Scan
(Parser => Parser,
Switch_Char => Switch_Char,
Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
Section_Delimiters => Section_Delimiters);
else
Parser := new Opt_Parser_Data (Command_Line'Length);
Parser.Arguments := Command_Line;
Internal_Initialize_Option_Scan
(Parser => Parser,
Switch_Char => Switch_Char,
Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
Section_Delimiters => Section_Delimiters);
end if;
end Initialize_Option_Scan;
-------------------------------------
-- Internal_Initialize_Option_Scan --
-------------------------------------
procedure Internal_Initialize_Option_Scan
(Parser : Opt_Parser;
Switch_Char : Character;
Stop_At_First_Non_Switch : Boolean;
Section_Delimiters : String)
is
Section_Num : Section_Number;
Section_Index : Integer;
Last : Integer;
Delimiter_Found : Boolean;
Discard : Boolean;
pragma Warnings (Off, Discard);
begin
Parser.Current_Argument := 0;
Parser.Current_Index := 0;
Parser.In_Expansion := False;
Parser.Switch_Character := Switch_Char;
Parser.Stop_At_First := Stop_At_First_Non_Switch;
Parser.Section := [others => 1];
-- If we are using sections, we have to preprocess the command line to
-- delimit them. A section can be repeated, so we just give each item
-- on the command line a section number
Section_Num := 1;
Section_Index := Section_Delimiters'First;
while Section_Index <= Section_Delimiters'Last loop
Last := Section_Index;
while Last <= Section_Delimiters'Last
and then Section_Delimiters (Last) /= ' '
loop
Last := Last + 1;
end loop;
Delimiter_Found := False;
Section_Num := Section_Num + 1;
for Index in 1 .. Parser.Arg_Count loop
pragma Assert (Argument (Parser, Index)'First = 1);
if Argument (Parser, Index) /= ""
and then Argument (Parser, Index)(1) = Parser.Switch_Character
and then
Argument (Parser, Index) = Parser.Switch_Character &
Section_Delimiters
(Section_Index .. Last - 1)
then
Parser.Section (Index) := 0;
Delimiter_Found := True;
elsif Parser.Section (Index) = 0 then
-- A previous section delimiter
Delimiter_Found := False;
elsif Delimiter_Found then
Parser.Section (Index) := Section_Num;
end if;
end loop;
Section_Index := Last + 1;
while Section_Index <= Section_Delimiters'Last
and then Section_Delimiters (Section_Index) = ' '
loop
Section_Index := Section_Index + 1;
end loop;
end loop;
Discard := Goto_Next_Argument_In_Section (Parser);
end Internal_Initialize_Option_Scan;
---------------
-- Parameter --
---------------
function Parameter
(Parser : Opt_Parser := Command_Line_Parser) return String
is
begin
if Parser.The_Parameter.First > Parser.The_Parameter.Last then
return String'(1 .. 0 => ' ');
else
return Argument (Parser, Parser.The_Parameter.Arg_Num)
(Parser.The_Parameter.First .. Parser.The_Parameter.Last);
end if;
end Parameter;
---------------
-- Separator --
---------------
function Separator
(Parser : Opt_Parser := Command_Line_Parser) return Character
is
begin
return Parser.The_Separator;
end Separator;
-------------------
-- Set_Parameter --
-------------------
procedure Set_Parameter
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
Last : Natural;
Extra : Character := ASCII.NUL)
is
begin
Variable.Arg_Num := Arg_Num;
Variable.First := First;
Variable.Last := Last;
Variable.Extra := Extra;
end Set_Parameter;
---------------------
-- Start_Expansion --
---------------------
procedure Start_Expansion
(Iterator : out Expansion_Iterator;
Pattern : String;
Directory : String := "";
Basic_Regexp : Boolean := True)
is
Directory_Separator : Character;
pragma Import (C, Directory_Separator, "__gnat_dir_separator");
First : Positive := Pattern'First;
Pat : String := Pattern;
begin
Canonical_Case_File_Name (Pat);
Iterator.Current_Depth := 1;
-- If Directory is unspecified, use the current directory ("./" or ".\")
if Directory = "" then
Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator;
Iterator.Start := 3;
else
Iterator.Dir_Name (1 .. Directory'Length) := Directory;
Iterator.Start := Directory'Length + 1;
Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length));
-- Make sure that the last character is a directory separator
if Directory (Directory'Last) /= Directory_Separator then
Iterator.Dir_Name (Iterator.Start) := Directory_Separator;
Iterator.Start := Iterator.Start + 1;
end if;
end if;
Iterator.Levels (1).Name_Last := Iterator.Start - 1;
-- Open the initial Directory, at depth 1
GNAT.Directory_Operations.Open
(Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1));
-- If in the current directory and the pattern starts with "./" or ".\",
-- drop the "./" or ".\" from the pattern.
if Directory = "" and then Pat'Length > 2
and then Pat (Pat'First) = '.'
and then Pat (Pat'First + 1) = Directory_Separator
then
First := Pat'First + 2;
end if;
Iterator.Regexp :=
GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True);
Iterator.Maximum_Depth := 1;
-- Maximum_Depth is equal to 1 plus the number of directory separators
-- in the pattern.
for Index in First .. Pat'Last loop
if Pat (Index) = Directory_Separator then
Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1;
exit when Iterator.Maximum_Depth = Max_Depth;
end if;
end loop;
end Start_Expansion;
----------
-- Free --
----------
procedure Free (Parser : in out Opt_Parser) is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser);
begin
if Parser /= null and then Parser /= Command_Line_Parser then
Free (Parser.Arguments);
Unchecked_Free (Parser);
end if;
end Free;
------------------
-- Define_Alias --
------------------
procedure Define_Alias
(Config : in out Command_Line_Configuration;
Switch : String;
Expanded : String;
Section : String := "")
is
Def : Alias_Definition;
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
end if;
Def.Alias := new String'(Switch);
Def.Expansion := new String'(Expanded);
Def.Section := new String'(Section);
Add (Config.Aliases, Def);
end Define_Alias;
-------------------
-- Define_Prefix --
-------------------
procedure Define_Prefix
(Config : in out Command_Line_Configuration;
Prefix : String)
is
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
end if;
Add (Config.Prefixes, new String'(Prefix));
end Define_Prefix;
---------
-- Add --
---------
procedure Add
(Config : in out Command_Line_Configuration;
Switch : Switch_Definition)
is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Switch_Definitions, Switch_Definitions_List);
Tmp : Switch_Definitions_List;
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
end if;
Tmp := Config.Switches;
if Tmp = null then
Config.Switches := new Switch_Definitions (1 .. 1);
else
Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1);
Config.Switches (1 .. Tmp'Length) := Tmp.all;
Unchecked_Free (Tmp);
end if;
if Switch.Switch /= null and then Switch.Switch.all = "*" then
Config.Star_Switch := True;
end if;
Config.Switches (Config.Switches'Last) := Switch;
end Add;
---------
-- Add --
---------
procedure Add
(Def : in out Alias_Definitions_List;
Alias : Alias_Definition)
is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation
(Alias_Definitions, Alias_Definitions_List);
Tmp : Alias_Definitions_List := Def;
begin
if Tmp = null then
Def := new Alias_Definitions (1 .. 1);
else
Def := new Alias_Definitions (1 .. Tmp'Length + 1);
Def (1 .. Tmp'Length) := Tmp.all;
Unchecked_Free (Tmp);
end if;
Def (Def'Last) := Alias;
end Add;
---------------------------
-- Initialize_Switch_Def --
---------------------------
procedure Initialize_Switch_Def
(Def : out Switch_Definition;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Argument : String := "ARG")
is
P1, P2 : Switch_Parameter_Type := Parameter_None;
Last1, Last2 : Integer;
begin
if Switch /= "" then
Def.Switch := new String'(Switch);
Decompose_Switch (Switch, P1, Last1);
end if;
if Long_Switch /= "" then
Def.Long_Switch := new String'(Long_Switch);
Decompose_Switch (Long_Switch, P2, Last2);
end if;
if Switch /= "" and then Long_Switch /= "" then
if (P1 = Parameter_None and then P2 /= P1)
or else (P2 = Parameter_None and then P1 /= P2)
or else (P1 = Parameter_Optional and then P2 /= P1)
or else (P2 = Parameter_Optional and then P2 /= P1)
then
raise Invalid_Switch
with "Inconsistent parameter types for "
& Switch & " and " & Long_Switch;
end if;
end if;
if Section /= "" then
Def.Section := new String'(Section);
end if;
if Argument /= "ARG" then
Def.Argument := new String'(Argument);
end if;
if Help /= "" then
Def.Help := new String'(Help);
end if;
end Initialize_Switch_Def;
-------------------
-- Define_Switch --
-------------------
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Argument : String := "ARG")
is
Def : Switch_Definition;
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument);
Add (Config, Def);
end if;
end Define_Switch;
-------------------
-- Define_Switch --
-------------------
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Output : access Boolean;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Value : Boolean := True)
is
Def : Switch_Definition (Switch_Boolean);
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
Def.Boolean_Output := Output.all'Unchecked_Access;
Def.Boolean_Value := Value;
Add (Config, Def);
end if;
end Define_Switch;
-------------------
-- Define_Switch --
-------------------
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Output : access Integer;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Initial : Integer := 0;
Default : Integer := 1;
Argument : String := "ARG")
is
Def : Switch_Definition (Switch_Integer);
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument);
Def.Integer_Output := Output.all'Unchecked_Access;
Def.Integer_Default := Default;
Def.Integer_Initial := Initial;
Add (Config, Def);
end if;
end Define_Switch;
-------------------
-- Define_Switch --
-------------------
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Output : access GNAT.Strings.String_Access;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Argument : String := "ARG")
is
Def : Switch_Definition (Switch_String);
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument);
Def.String_Output := Output.all'Unchecked_Access;
Add (Config, Def);
end if;
end Define_Switch;
-------------------
-- Define_Switch --
-------------------
procedure Define_Switch
(Config : in out Command_Line_Configuration;
Callback : not null Value_Callback;
Switch : String := "";
Long_Switch : String := "";
Help : String := "";
Section : String := "";
Argument : String := "ARG")
is
Def : Switch_Definition (Switch_Callback);
begin
if Switch /= "" or else Long_Switch /= "" then
Initialize_Switch_Def
(Def, Switch, Long_Switch, Help, Section, Argument);
Def.Callback := Callback;
Add (Config, Def);
end if;
end Define_Switch;
--------------------
-- Define_Section --
--------------------
procedure Define_Section
(Config : in out Command_Line_Configuration;
Section : String)
is
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
end if;
Add (Config.Sections, new String'(Section));
end Define_Section;
--------------------
-- Foreach_Switch --
--------------------
procedure Foreach_Switch
(Config : Command_Line_Configuration;
Section : String)
is
begin
if Config /= null and then Config.Switches /= null then
for J in Config.Switches'Range loop
if (Section = "" and then Config.Switches (J).Section = null)
or else
(Config.Switches (J).Section /= null
and then Config.Switches (J).Section.all = Section)
then
exit when Config.Switches (J).Switch /= null
and then not Callback (Config.Switches (J).Switch.all, J);
exit when Config.Switches (J).Long_Switch /= null
and then
not Callback (Config.Switches (J).Long_Switch.all, J);
end if;
end loop;
end if;
end Foreach_Switch;
------------------
-- Get_Switches --
------------------
function Get_Switches
(Config : Command_Line_Configuration;
Switch_Char : Character := '-';
Section : String := "") return String
is
Ret : Ada.Strings.Unbounded.Unbounded_String;
use Ada.Strings.Unbounded;
function Add_Switch (S : String; Index : Integer) return Boolean;
-- Add a switch to Ret
----------------
-- Add_Switch --
----------------
function Add_Switch (S : String; Index : Integer) return Boolean is
pragma Unreferenced (Index);
begin
if S = "*" then
Ret := "*" & Ret; -- Always first
elsif S (S'First) = Switch_Char then
Append (Ret, " " & S (S'First + 1 .. S'Last));
else
Append (Ret, " " & S);
end if;
return True;
end Add_Switch;
Tmp : Boolean;
pragma Unreferenced (Tmp);
procedure Foreach is new Foreach_Switch (Add_Switch);
-- Start of processing for Get_Switches
begin
if Config = null then
return "";
end if;
Foreach (Config, Section => Section);
-- Add relevant aliases
if Config.Aliases /= null then
for A in Config.Aliases'Range loop
if Config.Aliases (A).Section.all = Section then
Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1);
end if;
end loop;
end if;
return To_String (Ret);
end Get_Switches;
------------------------
-- Section_Delimiters --
------------------------
function Section_Delimiters
(Config : Command_Line_Configuration) return String
is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin
if Config /= null and then Config.Sections /= null then
for S in Config.Sections'Range loop
Append (Result, " " & Config.Sections (S).all);
end loop;
end if;
return To_String (Result);
end Section_Delimiters;
-----------------------
-- Set_Configuration --
-----------------------
procedure Set_Configuration
(Cmd : in out Command_Line;
Config : Command_Line_Configuration)
is
begin
Cmd.Config := Config;
end Set_Configuration;
-----------------------
-- Get_Configuration --
-----------------------
function Get_Configuration
(Cmd : Command_Line) return Command_Line_Configuration
is
begin
return Cmd.Config;
end Get_Configuration;
----------------------
-- Set_Command_Line --
----------------------
procedure Set_Command_Line
(Cmd : in out Command_Line;
Switches : String;
Getopt_Description : String := "";
Switch_Char : Character := '-')
is
Tmp : Argument_List_Access;
Parser : Opt_Parser;
S : Character;
Section : String_Access := null;
function Real_Full_Switch
(S : Character;
Parser : Opt_Parser) return String;
-- Ensure that the returned switch value contains the Switch_Char prefix
-- if needed.
----------------------
-- Real_Full_Switch --
----------------------
function Real_Full_Switch
(S : Character;
Parser : Opt_Parser) return String
is
begin
if S = '*' then
return Full_Switch (Parser);
else
return Switch_Char & Full_Switch (Parser);
end if;
end Real_Full_Switch;
-- Start of processing for Set_Command_Line
begin
Free (Cmd.Expanded);
Free (Cmd.Params);
if Switches /= "" then
Tmp := Argument_String_To_List (Switches);
Initialize_Option_Scan (Parser, Tmp, Switch_Char);
loop
begin
if Cmd.Config /= null then
-- Do not use Getopt_Description in this case. Otherwise,
-- if we have defined a prefix -gnaty, and two switches
-- -gnatya and -gnatyL!, we would have a different behavior
-- depending on the order of switches:
-- -gnatyL1a => -gnatyL with argument "1a"
-- -gnatyaL1 => -gnatya and -gnatyL with argument "1"
-- This is because the call to Getopt below knows nothing
-- about prefixes, and in the first case finds a valid
-- switch with arguments, so returns it without analyzing
-- the argument. In the second case, the switch matches "*",
-- and is then decomposed below.
-- Note: When a Command_Line object is associated with a
-- Command_Line_Config (which is mostly the case for tools
-- that let users choose the command line before spawning
-- other tools, for instance IDEs), the configuration of
-- the switches must be taken from the Command_Line_Config.
S := Getopt (Switches => "* " & Get_Switches (Cmd.Config),
Concatenate => False,
Parser => Parser);
else
S := Getopt (Switches => "* " & Getopt_Description,
Concatenate => False,
Parser => Parser);
end if;
exit when S = ASCII.NUL;
declare
Sw : constant String := Real_Full_Switch (S, Parser);
Is_Section : Boolean := False;
begin
if Cmd.Config /= null
and then Cmd.Config.Sections /= null
then
Section_Search :
for S in Cmd.Config.Sections'Range loop
if Sw = Cmd.Config.Sections (S).all then
Section := Cmd.Config.Sections (S);
Is_Section := True;
exit Section_Search;
end if;
end loop Section_Search;
end if;
if not Is_Section then
if Section = null then
Add_Switch (Cmd, Sw, Parameter (Parser));
else
Add_Switch
(Cmd, Sw, Parameter (Parser),
Section => Section.all);
end if;
end if;
end;
exception
when Invalid_Parameter =>
-- Add it with no parameter, if that's the way the user
-- wants it.
-- Specify the separator in all cases, as the switch might
-- need to be unaliased, and the alias might contain
-- switches with parameters.
if Section = null then
Add_Switch
(Cmd, Switch_Char & Full_Switch (Parser));
else
Add_Switch
(Cmd, Switch_Char & Full_Switch (Parser),
Section => Section.all);
end if;
end;
end loop;
Free (Parser);
end if;
end Set_Command_Line;
----------------
-- Looking_At --
----------------
function Looking_At
(Type_Str : String;
Index : Natural;
Substring : String) return Boolean
is
begin
return Index + Substring'Length - 1 <= Type_Str'Last
and then Type_Str (Index .. Index + Substring'Length - 1) = Substring;
end Looking_At;
------------------------
-- Can_Have_Parameter --
------------------------
function Can_Have_Parameter (S : String) return Boolean is
begin
if S'Length <= 1 then
return False;
end if;
case S (S'Last) is
when '!' | ':' | '?' | '=' =>
return True;
when others =>
return False;
end case;
end Can_Have_Parameter;
-----------------------
-- Require_Parameter --
-----------------------
function Require_Parameter (S : String) return Boolean is
begin
if S'Length <= 1 then
return False;
end if;
case S (S'Last) is
when '!' | ':' | '=' =>
return True;
when others =>
return False;
end case;
end Require_Parameter;
-------------------
-- Actual_Switch --
-------------------
function Actual_Switch (S : String) return String is
begin
if S'Length <= 1 then
return S;
end if;
case S (S'Last) is
when '!' | ':' | '?' | '=' =>
return S (S'First .. S'Last - 1);
when others =>
return S;
end case;
end Actual_Switch;
----------------------------
-- For_Each_Simple_Switch --
----------------------------
procedure For_Each_Simple_Switch
(Config : Command_Line_Configuration;
Section : String;
Switch : String;
Parameter : String := "";
Unalias : Boolean := True)
is
function Group_Analysis
(Prefix : String;
Group : String) return Boolean;
-- Perform the analysis of a group of switches
Found_In_Config : Boolean := False;
function Is_In_Config
(Config_Switch : String; Index : Integer) return Boolean;
-- If Switch is the same as Config_Switch, run the callback and sets
-- Found_In_Config to True.
function Starts_With
(Config_Switch : String; Index : Integer) return Boolean;
-- if Switch starts with Config_Switch, sets Found_In_Config to True.
-- The return value is for the Foreach_Switch iterator.
--------------------
-- Group_Analysis --
--------------------
function Group_Analysis
(Prefix : String;
Group : String) return Boolean
is
Idx : Natural;
Found : Boolean;
function Analyze_Simple_Switch
(Switch : String; Index : Integer) return Boolean;
-- "Switches" is one of the switch definitions passed to the
-- configuration, not one of the switches found on the command line.
---------------------------
-- Analyze_Simple_Switch --
---------------------------
function Analyze_Simple_Switch
(Switch : String; Index : Integer) return Boolean
is
pragma Unreferenced (Index);
Full : constant String := Prefix & Group (Idx .. Group'Last);
Sw : constant String := Actual_Switch (Switch);
-- Switches definition minus argument definition
Last : Natural;
Param : Natural;
begin
-- Verify that sw starts with Prefix
if Looking_At (Sw, Sw'First, Prefix)
-- Verify that the group starts with sw
and then Looking_At (Full, Full'First, Sw)
then
Last := Idx + Sw'Length - Prefix'Length - 1;
Param := Last + 1;
if Can_Have_Parameter (Switch) then
-- Include potential parameter to the recursive call. Only
-- numbers are allowed.
while Last < Group'Last
and then Group (Last + 1) in '0' .. '9'
loop
Last := Last + 1;
end loop;
end if;
if not Require_Parameter (Switch) or else Last >= Param then
if Idx = Group'First
and then Last = Group'Last
and then Last < Param
then
-- The group only concerns a single switch. Do not
-- perform recursive call.
-- Note that we still perform a recursive call if
-- a parameter is detected in the switch, as this
-- is a way to correctly identify such a parameter
-- in aliases.
return False;
end if;
Found := True;
-- Recursive call, using the detected parameter if any
if Last >= Param then
For_Each_Simple_Switch
(Config,
Section,
Prefix & Group (Idx .. Param - 1),
Group (Param .. Last));
else
For_Each_Simple_Switch
(Config, Section, Prefix & Group (Idx .. Last), "");
end if;
Idx := Last + 1;
return False;
end if;
end if;
return True;
end Analyze_Simple_Switch;
procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch);
-- Start of processing for Group_Analysis
begin
Idx := Group'First;
while Idx <= Group'Last loop
Found := False;
Foreach (Config, Section);
if not Found then
For_Each_Simple_Switch
(Config, Section, Prefix & Group (Idx), "");
Idx := Idx + 1;
end if;
end loop;
return True;
end Group_Analysis;
------------------
-- Is_In_Config --
------------------
function Is_In_Config
(Config_Switch : String; Index : Integer) return Boolean
is
Last : Natural;
P : Switch_Parameter_Type;
begin
Decompose_Switch (Config_Switch, P, Last);
if Config_Switch (Config_Switch'First .. Last) = Switch then
case P is
when Parameter_None =>
if Parameter = "" then
Callback (Switch, "", "", Index => Index);
Found_In_Config := True;
return False;
end if;
when Parameter_With_Optional_Space =>
Callback (Switch, " ", Parameter, Index => Index);
Found_In_Config := True;
return False;
when Parameter_With_Space_Or_Equal =>
Callback (Switch, "=", Parameter, Index => Index);
Found_In_Config := True;
return False;
when Parameter_No_Space
| Parameter_Optional
=>
Callback (Switch, "", Parameter, Index);
Found_In_Config := True;
return False;
end case;
end if;
return True;
end Is_In_Config;
-----------------
-- Starts_With --
-----------------
function Starts_With
(Config_Switch : String; Index : Integer) return Boolean
is
Last : Natural;
Param : Natural;
P : Switch_Parameter_Type;
begin
-- This function is called when we believe the parameter was
-- specified as part of the switch, instead of separately. Thus we
-- look in the config to find all possible switches.
Decompose_Switch (Config_Switch, P, Last);
if Looking_At
(Switch, Switch'First,
Config_Switch (Config_Switch'First .. Last))
then
-- Set first char of Param, and last char of Switch
Param := Switch'First + Last;
Last := Switch'First + Last - Config_Switch'First;
case P is
-- None is already handled in Is_In_Config
when Parameter_None =>
null;
when Parameter_With_Space_Or_Equal =>
if Param <= Switch'Last
and then
(Switch (Param) = ' ' or else Switch (Param) = '=')
then
Callback (Switch (Switch'First .. Last),
"=", Switch (Param + 1 .. Switch'Last), Index);
Found_In_Config := True;
return False;
end if;
when Parameter_With_Optional_Space =>
if Param <= Switch'Last and then Switch (Param) = ' ' then
Param := Param + 1;
end if;
Callback (Switch (Switch'First .. Last),
" ", Switch (Param .. Switch'Last), Index);
Found_In_Config := True;
return False;
when Parameter_No_Space
| Parameter_Optional
=>
Callback (Switch (Switch'First .. Last),
"", Switch (Param .. Switch'Last), Index);
Found_In_Config := True;
return False;
end case;
end if;
return True;
end Starts_With;
procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config);
procedure Foreach_Starts_With is new Foreach_Switch (Starts_With);
-- Start of processing for For_Each_Simple_Switch
begin
-- First determine if the switch corresponds to one belonging to the
-- configuration. If so, run callback and exit.
-- ??? Is this necessary. On simple tests, we seem to have the same
-- results with or without this call.
Foreach_In_Config (Config, Section);
if Found_In_Config then
return;
end if;
-- If adding a switch that can in fact be expanded through aliases,
-- add separately each of its expansions.
-- This takes care of expansions like "-T" -> "-gnatwrs", where the
-- alias and its expansion do not have the same prefix. Given the order
-- in which we do things here, the expansion of the alias will itself
-- be checked for a common prefix and split into simple switches.
if Unalias
and then Config /= null
and then Config.Aliases /= null
then
for A in Config.Aliases'Range loop
if Config.Aliases (A).Section.all = Section
and then Config.Aliases (A).Alias.all = Switch
and then Parameter = ""
then
For_Each_Simple_Switch
(Config, Section, Config.Aliases (A).Expansion.all, "");
return;
end if;
end loop;
end if;
-- If adding a switch grouping several switches, add each of the simple
-- switches instead.
if Config /= null and then Config.Prefixes /= null then
for P in Config.Prefixes'Range loop
if Switch'Length > Config.Prefixes (P)'Length + 1
and then
Looking_At (Switch, Switch'First, Config.Prefixes (P).all)
then
-- Alias expansion will be done recursively
if Config.Switches = null then
for S in Switch'First + Config.Prefixes (P)'Length
.. Switch'Last
loop
For_Each_Simple_Switch
(Config, Section,
Config.Prefixes (P).all & Switch (S), "");
end loop;
return;
elsif Group_Analysis
(Config.Prefixes (P).all,
Switch
(Switch'First + Config.Prefixes (P)'Length .. Switch'Last))
then
-- Recursive calls already done on each switch of the group:
-- Return without executing Callback.
return;
end if;
end if;
end loop;
end if;
-- Test if added switch is a known switch with parameter attached
-- instead of being specified separately
if Parameter = ""
and then Config /= null
and then Config.Switches /= null
then
Found_In_Config := False;
Foreach_Starts_With (Config, Section);
if Found_In_Config then
return;
end if;
end if;
-- The switch is invalid in the config, but we still want to report it.
-- The config could, for instance, include "*" to specify it accepts
-- all switches.
Callback (Switch, " ", Parameter, Index => -1);
end For_Each_Simple_Switch;
----------------
-- Add_Switch --
----------------
procedure Add_Switch
(Cmd : in out Command_Line;
Switch : String;
Parameter : String := "";
Separator : Character := ASCII.NUL;
Section : String := "";
Add_Before : Boolean := False)
is
Success : Boolean;
pragma Unreferenced (Success);
begin
Add_Switch (Cmd, Switch, Parameter, Separator,
Section, Add_Before, Success);
end Add_Switch;
----------------
-- Add_Switch --
----------------
procedure Add_Switch
(Cmd : in out Command_Line;
Switch : String;
Parameter : String := "";
Separator : Character := ASCII.NUL;
Section : String := "";
Add_Before : Boolean := False;
Success : out Boolean)
is
procedure Add_Simple_Switch
(Simple : String;
Sepa : String;
Param : String;
Index : Integer);
-- Add a new switch that has had all its aliases expanded, and switches
-- ungrouped. We know there are no more aliases in Switches.
-----------------------
-- Add_Simple_Switch --
-----------------------
procedure Add_Simple_Switch
(Simple : String;
Sepa : String;
Param : String;
Index : Integer)
is
Sep : Character;
begin
if Index = -1
and then Cmd.Config /= null
and then not Cmd.Config.Star_Switch
then
raise Invalid_Switch
with "Invalid switch " & Simple;
end if;
if Separator /= ASCII.NUL then
Sep := Separator;
elsif Sepa = "" then
Sep := ASCII.NUL;
else
Sep := Sepa (Sepa'First);
end if;
if Cmd.Expanded = null then
Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple));
if Param /= "" then
Cmd.Params :=
new Argument_List'(1 .. 1 => new String'(Sep & Param));
else
Cmd.Params := new Argument_List'(1 .. 1 => null);
end if;
if Section = "" then
Cmd.Sections := new Argument_List'(1 .. 1 => null);
else
Cmd.Sections :=
new Argument_List'(1 .. 1 => new String'(Section));
end if;
else
-- Do we already have this switch?
for C in Cmd.Expanded'Range loop
if Cmd.Expanded (C).all = Simple
and then
((Cmd.Params (C) = null and then Param = "")
or else
(Cmd.Params (C) /= null
and then Cmd.Params (C).all = Sep & Param))
and then
((Cmd.Sections (C) = null and then Section = "")
or else
(Cmd.Sections (C) /= null
and then Cmd.Sections (C).all = Section))
then
return;
end if;
end loop;
-- Inserting at least one switch
Success := True;
Add (Cmd.Expanded, new String'(Simple), Add_Before);
if Param /= "" then
Add
(Cmd.Params,
new String'(Sep & Param),
Add_Before);
else
Add
(Cmd.Params,
null,
Add_Before);
end if;
if Section = "" then
Add
(Cmd.Sections,
null,
Add_Before);
else
Add
(Cmd.Sections,
new String'(Section),
Add_Before);
end if;
end if;
end Add_Simple_Switch;
procedure Add_Simple_Switches is
new For_Each_Simple_Switch (Add_Simple_Switch);
-- Local Variables
Section_Valid : Boolean := False;
-- Start of processing for Add_Switch
begin
if Section /= "" and then Cmd.Config /= null then
for S in Cmd.Config.Sections'Range loop
if Section = Cmd.Config.Sections (S).all then
Section_Valid := True;
exit;
end if;
end loop;
if not Section_Valid then
raise Invalid_Section;
end if;
end if;
Success := False;
Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
Free (Cmd.Coalesce);
end Add_Switch;
------------
-- Remove --
------------
procedure Remove (Line : in out Argument_List_Access; Index : Integer) is
Tmp : Argument_List_Access := Line;
begin
Line := new Argument_List (Tmp'First .. Tmp'Last - 1);
if Index /= Tmp'First then
Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1);
end if;
Free (Tmp (Index));
if Index /= Tmp'Last then
Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last);
end if;
Unchecked_Free (Tmp);
end Remove;
---------
-- Add --
---------
procedure Add
(Line : in out Argument_List_Access;
Str : String_Access;
Before : Boolean := False)
is
Tmp : Argument_List_Access := Line;
begin
if Tmp /= null then
Line := new Argument_List (Tmp'First .. Tmp'Last + 1);
if Before then
Line (Tmp'First) := Str;
Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all;
else
Line (Tmp'Range) := Tmp.all;
Line (Tmp'Last + 1) := Str;
end if;
Unchecked_Free (Tmp);
else
Line := new Argument_List'(1 .. 1 => Str);
end if;
end Add;
-------------------
-- Remove_Switch --
-------------------
procedure Remove_Switch
(Cmd : in out Command_Line;
Switch : String;
Remove_All : Boolean := False;
Has_Parameter : Boolean := False;
Section : String := "")
is
Success : Boolean;
pragma Unreferenced (Success);
begin
Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success);
end Remove_Switch;
-------------------
-- Remove_Switch --
-------------------
procedure Remove_Switch
(Cmd : in out Command_Line;
Switch : String;
Remove_All : Boolean := False;
Has_Parameter : Boolean := False;
Section : String := "";
Success : out Boolean)
is
procedure Remove_Simple_Switch
(Simple, Separator, Param : String; Index : Integer);
-- Removes a simple switch, with no aliasing or grouping
--------------------------
-- Remove_Simple_Switch --
--------------------------
procedure Remove_Simple_Switch
(Simple, Separator, Param : String; Index : Integer)
is
C : Integer;
pragma Unreferenced (Param, Separator, Index);
begin
if Cmd.Expanded /= null then
C := Cmd.Expanded'First;
while C <= Cmd.Expanded'Last loop
if Cmd.Expanded (C).all = Simple
and then
(Remove_All
or else (Cmd.Sections (C) = null
and then Section = "")
or else (Cmd.Sections (C) /= null
and then Section = Cmd.Sections (C).all))
and then (not Has_Parameter or else Cmd.Params (C) /= null)
then
Remove (Cmd.Expanded, C);
Remove (Cmd.Params, C);
Remove (Cmd.Sections, C);
Success := True;
if not Remove_All then
return;
end if;
else
C := C + 1;
end if;
end loop;
end if;
end Remove_Simple_Switch;
procedure Remove_Simple_Switches is
new For_Each_Simple_Switch (Remove_Simple_Switch);
-- Start of processing for Remove_Switch
begin
Success := False;
Remove_Simple_Switches
(Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter);
Free (Cmd.Coalesce);
end Remove_Switch;
-------------------
-- Remove_Switch --
-------------------
procedure Remove_Switch
(Cmd : in out Command_Line;
Switch : String;
Parameter : String;
Section : String := "")
is
procedure Remove_Simple_Switch
(Simple, Separator, Param : String; Index : Integer);
-- Removes a simple switch, with no aliasing or grouping
--------------------------
-- Remove_Simple_Switch --
--------------------------
procedure Remove_Simple_Switch
(Simple, Separator, Param : String; Index : Integer)
is
pragma Unreferenced (Separator, Index);
C : Integer;
begin
if Cmd.Expanded /= null then
C := Cmd.Expanded'First;
while C <= Cmd.Expanded'Last loop
if Cmd.Expanded (C).all = Simple
and then
((Cmd.Sections (C) = null
and then Section = "")
or else
(Cmd.Sections (C) /= null
and then Section = Cmd.Sections (C).all))
and then
((Cmd.Params (C) = null and then Param = "")
or else
(Cmd.Params (C) /= null
-- Ignore the separator stored in Parameter
and then
Cmd.Params (C) (Cmd.Params (C)'First + 1
.. Cmd.Params (C)'Last) = Param))
then
Remove (Cmd.Expanded, C);
Remove (Cmd.Params, C);
Remove (Cmd.Sections, C);
-- The switch is necessarily unique by construction of
-- Add_Switch.
return;
else
C := C + 1;
end if;
end loop;
end if;
end Remove_Simple_Switch;
procedure Remove_Simple_Switches is
new For_Each_Simple_Switch (Remove_Simple_Switch);
-- Start of processing for Remove_Switch
begin
Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
Free (Cmd.Coalesce);
end Remove_Switch;
--------------------
-- Group_Switches --
--------------------
procedure Group_Switches
(Cmd : Command_Line;
Result : Argument_List_Access;
Sections : Argument_List_Access;
Params : Argument_List_Access)
is
function Compatible_Parameter (Param : String_Access) return Boolean;
-- True when the parameter can be part of a group
--------------------------
-- Compatible_Parameter --
--------------------------
function Compatible_Parameter (Param : String_Access) return Boolean is
begin
-- No parameter OK
if Param = null then
return True;
-- We need parameters without separators
elsif Param (Param'First) /= ASCII.NUL then
return False;
-- Parameters must be all digits
else
for J in Param'First + 1 .. Param'Last loop
if Param (J) not in '0' .. '9' then
return False;
end if;
end loop;
return True;
end if;
end Compatible_Parameter;
-- Local declarations
Group : Ada.Strings.Unbounded.Unbounded_String;
First : Natural;
use type Ada.Strings.Unbounded.Unbounded_String;
-- Start of processing for Group_Switches
begin
if Cmd.Config = null or else Cmd.Config.Prefixes = null then
return;
end if;
for P in Cmd.Config.Prefixes'Range loop
Group := Ada.Strings.Unbounded.Null_Unbounded_String;
First := 0;
for C in Result'Range loop
if Result (C) /= null
and then Compatible_Parameter (Params (C))
and then Looking_At
(Result (C).all,
Result (C)'First,
Cmd.Config.Prefixes (P).all)
then
-- If we are still in the same section, group the switches
if First = 0
or else
(Sections (C) = null
and then Sections (First) = null)
or else
(Sections (C) /= null
and then Sections (First) /= null
and then Sections (C).all = Sections (First).all)
then
Group :=
Group &
Result (C)
(Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
Result (C)'Last);
if Params (C) /= null then
Group :=
Group &
Params (C) (Params (C)'First + 1 .. Params (C)'Last);
Free (Params (C));
end if;
if First = 0 then
First := C;
end if;
Free (Result (C));
-- We changed section: we put the grouped switches to the first
-- place, on continue with the new section.
else
Result (First) :=
new String'
(Cmd.Config.Prefixes (P).all &
Ada.Strings.Unbounded.To_String (Group));
Group :=
Ada.Strings.Unbounded.To_Unbounded_String
(Result (C)
(Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
Result (C)'Last));
First := C;
end if;
end if;
end loop;
if First > 0 then
Result (First) :=
new String'
(Cmd.Config.Prefixes (P).all &
Ada.Strings.Unbounded.To_String (Group));
end if;
end loop;
end Group_Switches;
--------------------
-- Alias_Switches --
--------------------
procedure Alias_Switches
(Cmd : Command_Line;
Result : Argument_List_Access;
Params : Argument_List_Access)
is
Found : Boolean;
First : Natural;
procedure Check_Cb (Switch, Separator, Param : String; Index : Integer);
-- Checks whether the command line contains [Switch]. Sets the global
-- variable [Found] appropriately. This is called for each simple switch
-- that make up an alias, to know whether the alias should be applied.
procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer);
-- Remove the simple switch [Switch] from the command line, since it is
-- part of a simpler alias
--------------
-- Check_Cb --
--------------
procedure Check_Cb
(Switch, Separator, Param : String; Index : Integer)
is
pragma Unreferenced (Separator, Index);
begin
if Found then
for E in Result'Range loop
if Result (E) /= null
and then
(Params (E) = null
or else Params (E) (Params (E)'First + 1 ..
Params (E)'Last) = Param)
and then Result (E).all = Switch
then
return;
end if;
end loop;
Found := False;
end if;
end Check_Cb;
---------------
-- Remove_Cb --
---------------
procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer)
is
pragma Unreferenced (Separator, Index);
begin
for E in Result'Range loop
if Result (E) /= null
and then
(Params (E) = null
or else Params (E) (Params (E)'First + 1
.. Params (E)'Last) = Param)
and then Result (E).all = Switch
then
if First > E then
First := E;
end if;
Free (Result (E));
Free (Params (E));
return;
end if;
end loop;
end Remove_Cb;
procedure Check_All is new For_Each_Simple_Switch (Check_Cb);
procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb);
-- Start of processing for Alias_Switches
begin
if Cmd.Config = null or else Cmd.Config.Aliases = null then
return;
end if;
for A in Cmd.Config.Aliases'Range loop
-- Compute the various simple switches that make up the alias. We
-- split the expansion into as many simple switches as possible, and
-- then check whether the expanded command line has all of them.
Found := True;
Check_All (Cmd.Config,
Switch => Cmd.Config.Aliases (A).Expansion.all,
Section => Cmd.Config.Aliases (A).Section.all);
if Found then
First := Integer'Last;
Remove_All (Cmd.Config,
Switch => Cmd.Config.Aliases (A).Expansion.all,
Section => Cmd.Config.Aliases (A).Section.all);
Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all);
end if;
end loop;
end Alias_Switches;
-------------------
-- Sort_Sections --
-------------------
procedure Sort_Sections
(Line : not null GNAT.OS_Lib.Argument_List_Access;
Sections : GNAT.OS_Lib.Argument_List_Access;
Params : GNAT.OS_Lib.Argument_List_Access)
is
Sections_List : Argument_List_Access :=
new Argument_List'(1 .. 1 => null);
Found : Boolean;
Old_Line : constant Argument_List := Line.all;
Old_Sections : constant Argument_List := Sections.all;
Old_Params : constant Argument_List := Params.all;
Index : Natural;
begin
-- First construct a list of all sections
for E in Line'Range loop
if Sections (E) /= null then
Found := False;
for S in Sections_List'Range loop
if (Sections_List (S) = null and then Sections (E) = null)
or else
(Sections_List (S) /= null
and then Sections (E) /= null
and then Sections_List (S).all = Sections (E).all)
then
Found := True;
exit;
end if;
end loop;
if not Found then
Add (Sections_List, Sections (E));
end if;
end if;
end loop;
Index := Line'First;
for S in Sections_List'Range loop
for E in Old_Line'Range loop
if (Sections_List (S) = null and then Old_Sections (E) = null)
or else
(Sections_List (S) /= null
and then Old_Sections (E) /= null
and then Sections_List (S).all = Old_Sections (E).all)
then
Line (Index) := Old_Line (E);
Sections (Index) := Old_Sections (E);
Params (Index) := Old_Params (E);
Index := Index + 1;
end if;
end loop;
end loop;
Unchecked_Free (Sections_List);
end Sort_Sections;
-----------
-- Start --
-----------
procedure Start
(Cmd : in out Command_Line;
Iter : in out Command_Line_Iterator;
Expanded : Boolean := False)
is
begin
if Cmd.Expanded = null then
Iter.List := null;
return;
end if;
-- Reorder the expanded line so that sections are grouped
Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params);
-- Coalesce the switches as much as possible
if not Expanded
and then Cmd.Coalesce = null
then
Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range);
for E in Cmd.Expanded'Range loop
Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all);
end loop;
Free (Cmd.Coalesce_Sections);
Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range);
for E in Cmd.Sections'Range loop
Cmd.Coalesce_Sections (E) :=
(if Cmd.Sections (E) = null then null
else new String'(Cmd.Sections (E).all));
end loop;
Free (Cmd.Coalesce_Params);
Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range);
for E in Cmd.Params'Range loop
Cmd.Coalesce_Params (E) :=
(if Cmd.Params (E) = null then null
else new String'(Cmd.Params (E).all));
end loop;
-- Not a clone, since we will not modify the parameters anyway
Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params);
Group_Switches
(Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params);
end if;
if Expanded then
Iter.List := Cmd.Expanded;
Iter.Params := Cmd.Params;
Iter.Sections := Cmd.Sections;
else
Iter.List := Cmd.Coalesce;
Iter.Params := Cmd.Coalesce_Params;
Iter.Sections := Cmd.Coalesce_Sections;
end if;
if Iter.List = null then
Iter.Current := Integer'Last;
else
Iter.Current := Iter.List'First - 1;
Next (Iter);
end if;
end Start;
--------------------
-- Current_Switch --
--------------------
function Current_Switch (Iter : Command_Line_Iterator) return String is
begin
return Iter.List (Iter.Current).all;
end Current_Switch;
--------------------
-- Is_New_Section --
--------------------
function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is
Section : constant String := Current_Section (Iter);
begin
if Iter.Sections = null then
return False;
elsif Iter.Current = Iter.Sections'First
or else Iter.Sections (Iter.Current - 1) = null
then
return Section /= "";
else
return Section /= Iter.Sections (Iter.Current - 1).all;
end if;
end Is_New_Section;
---------------------
-- Current_Section --
---------------------
function Current_Section (Iter : Command_Line_Iterator) return String is
begin
if Iter.Sections = null
or else Iter.Current > Iter.Sections'Last
or else Iter.Sections (Iter.Current) = null
then
return "";
end if;
return Iter.Sections (Iter.Current).all;
end Current_Section;
-----------------------
-- Current_Separator --
-----------------------
function Current_Separator (Iter : Command_Line_Iterator) return String is
begin
if Iter.Params = null
or else Iter.Current > Iter.Params'Last
or else Iter.Params (Iter.Current) = null
then
return "";
else
declare
Sep : constant Character :=
Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First);
begin
if Sep = ASCII.NUL then
return "";
else
return "" & Sep;
end if;
end;
end if;
end Current_Separator;
-----------------------
-- Current_Parameter --
-----------------------
function Current_Parameter (Iter : Command_Line_Iterator) return String is
begin
if Iter.Params = null
or else Iter.Current > Iter.Params'Last
or else Iter.Params (Iter.Current) = null
then
return "";
else
-- Return result, skipping separator
declare
P : constant String := Iter.Params (Iter.Current).all;
begin
return P (P'First + 1 .. P'Last);
end;
end if;
end Current_Parameter;
--------------
-- Has_More --
--------------
function Has_More (Iter : Command_Line_Iterator) return Boolean is
begin
return Iter.List /= null and then Iter.Current <= Iter.List'Last;
end Has_More;
----------
-- Next --
----------
procedure Next (Iter : in out Command_Line_Iterator) is
begin
Iter.Current := Iter.Current + 1;
while Iter.Current <= Iter.List'Last
and then Iter.List (Iter.Current) = null
loop
Iter.Current := Iter.Current + 1;
end loop;
end Next;
----------
-- Free --
----------
procedure Free (Config : in out Command_Line_Configuration) is
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation
(Switch_Definitions, Switch_Definitions_List);
procedure Unchecked_Free is new
Ada.Unchecked_Deallocation
(Alias_Definitions, Alias_Definitions_List);
begin
if Config /= null then
Free (Config.Prefixes);
Free (Config.Sections);
Free (Config.Usage);
Free (Config.Help);
Free (Config.Help_Msg);
if Config.Aliases /= null then
for A in Config.Aliases'Range loop
Free (Config.Aliases (A).Alias);
Free (Config.Aliases (A).Expansion);
Free (Config.Aliases (A).Section);
end loop;
Unchecked_Free (Config.Aliases);
end if;
if Config.Switches /= null then
for S in Config.Switches'Range loop
Free (Config.Switches (S).Switch);
Free (Config.Switches (S).Long_Switch);
Free (Config.Switches (S).Help);
Free (Config.Switches (S).Section);
Free (Config.Switches (S).Argument);
end loop;
Unchecked_Free (Config.Switches);
end if;
Unchecked_Free (Config);
end if;
end Free;
----------
-- Free --
----------
procedure Free (Cmd : in out Command_Line) is
begin
Free (Cmd.Expanded);
Free (Cmd.Coalesce);
Free (Cmd.Coalesce_Sections);
Free (Cmd.Coalesce_Params);
Free (Cmd.Params);
Free (Cmd.Sections);
end Free;
---------------
-- Set_Usage --
---------------
procedure Set_Usage
(Config : in out Command_Line_Configuration;
Usage : String := "[switches] [arguments]";
Help : String := "";
Help_Msg : String := "")
is
begin
if Config = null then
Config := new Command_Line_Configuration_Record;
end if;
Free (Config.Usage);
Free (Config.Help);
Free (Config.Help_Msg);
Config.Usage := new String'(Usage);
Config.Help := new String'(Help);
Config.Help_Msg := new String'(Help_Msg);
end Set_Usage;
------------------
-- Display_Help --
------------------
procedure Display_Help (Config : Command_Line_Configuration) is
function Switch_Name
(Def : Switch_Definition;
Section : String) return String;
-- Return the "-short, --long=ARG" string for Def.
-- Returns "" if the switch is not in the section.
function Param_Name
(P : Switch_Parameter_Type;
Name : String := "ARG") return String;
-- Return the display for a switch parameter
procedure Display_Section_Help (Section : String);
-- Display the help for a specific section ("" is the default section)
--------------------------
-- Display_Section_Help --
--------------------------
procedure Display_Section_Help (Section : String) is
Max_Len : Natural := 0;
begin
-- ??? Special display for "*"
New_Line;
if Section /= "" then
Put_Line ("Switches after " & Section);
end if;
-- Compute size of the switches column
for S in Config.Switches'Range loop
Max_Len := Natural'Max
(Max_Len, Switch_Name (Config.Switches (S), Section)'Length);
end loop;
if Config.Aliases /= null then
for A in Config.Aliases'Range loop
if Config.Aliases (A).Section.all = Section then
Max_Len := Natural'Max
(Max_Len, Config.Aliases (A).Alias'Length);
end if;
end loop;
end if;
-- Display the switches
for S in Config.Switches'Range loop
declare
N : constant String :=
Switch_Name (Config.Switches (S), Section);
begin
if N /= "" then
Put (" ");
Put (N);
Put ([1 .. Max_Len - N'Length + 1 => ' ']);
if Config.Switches (S).Help /= null then
Put (Config.Switches (S).Help.all);
end if;
New_Line;
end if;
end;
end loop;
-- Display the aliases
if Config.Aliases /= null then
for A in Config.Aliases'Range loop
if Config.Aliases (A).Section.all = Section then
Put (" ");
Put (Config.Aliases (A).Alias.all);
Put ([1 .. Max_Len - Config.Aliases (A).Alias'Length + 1
=> ' ']);
Put ("Equivalent to " & Config.Aliases (A).Expansion.all);
New_Line;
end if;
end loop;
end if;
end Display_Section_Help;
----------------
-- Param_Name --
----------------
function Param_Name
(P : Switch_Parameter_Type;
Name : String := "ARG") return String
is
begin
case P is
when Parameter_None =>
return "";
when Parameter_With_Optional_Space =>
return " " & To_Upper (Name);
when Parameter_With_Space_Or_Equal =>
return "=" & To_Upper (Name);
when Parameter_No_Space =>
return To_Upper (Name);
when Parameter_Optional =>
return '[' & To_Upper (Name) & ']';
end case;
end Param_Name;
-----------------
-- Switch_Name --
-----------------
function Switch_Name
(Def : Switch_Definition;
Section : String) return String
is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
P1, P2 : Switch_Parameter_Type;
Last1, Last2 : Integer := 0;
begin
if (Section = "" and then Def.Section = null)
or else (Def.Section /= null and then Def.Section.all = Section)
then
if Def.Switch /= null and then Def.Switch.all = "*" then
return "[any switch]";
end if;
if Def.Switch /= null then
Decompose_Switch (Def.Switch.all, P1, Last1);
Append (Result, Def.Switch (Def.Switch'First .. Last1));
if Def.Long_Switch /= null then
Decompose_Switch (Def.Long_Switch.all, P2, Last2);
Append (Result, ", "
& Def.Long_Switch (Def.Long_Switch'First .. Last2));
if Def.Argument = null then
Append (Result, Param_Name (P2, "ARG"));
else
Append (Result, Param_Name (P2, Def.Argument.all));
end if;
else
if Def.Argument = null then
Append (Result, Param_Name (P1, "ARG"));
else
Append (Result, Param_Name (P1, Def.Argument.all));
end if;
end if;
-- Def.Switch is null (Long_Switch must be non-null)
else
Decompose_Switch (Def.Long_Switch.all, P2, Last2);
Append (Result,
Def.Long_Switch (Def.Long_Switch'First .. Last2));
if Def.Argument = null then
Append (Result, Param_Name (P2, "ARG"));
else
Append (Result, Param_Name (P2, Def.Argument.all));
end if;
end if;
end if;
return To_String (Result);
end Switch_Name;
-- Start of processing for Display_Help
begin
if Config = null then
return;
end if;
if Config.Help /= null and then Config.Help.all /= "" then
Put_Line (Config.Help.all);
end if;
if Config.Usage /= null then
Put_Line ("Usage: "
& Base_Name
(Ada.Command_Line.Command_Name) & " " & Config.Usage.all);
else
Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name)
& " [switches] [arguments]");
end if;
if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then
Put_Line (Config.Help_Msg.all);
else
Display_Section_Help ("");
if Config.Sections /= null and then Config.Switches /= null then
for S in Config.Sections'Range loop
Display_Section_Help (Config.Sections (S).all);
end loop;
end if;
end if;
end Display_Help;
------------
-- Getopt --
------------
procedure Getopt
(Config : Command_Line_Configuration;
Callback : Switch_Handler := null;
Parser : Opt_Parser := Command_Line_Parser;
Concatenate : Boolean := True;
Quiet : Boolean := False)
is
Local_Config : Command_Line_Configuration := Config;
Getopt_Switches : String_Access;
C : Character := ASCII.NUL;
Empty_Name : aliased constant String := "";
Current_Section : Integer := -1;
Section_Name : not null access constant String := Empty_Name'Access;
procedure Simple_Callback
(Simple_Switch : String;
Separator : String;
Parameter : String;
Index : Integer);
-- Needs comments ???
procedure Do_Callback (Switch, Parameter : String; Index : Integer);
-----------------
-- Do_Callback --
-----------------
procedure Do_Callback (Switch, Parameter : String; Index : Integer) is
begin
-- Do automatic handling when possible
if Index /= -1 then
case Local_Config.Switches (Index).Typ is
when Switch_Untyped =>
null; -- no automatic handling
when Switch_Boolean =>
Local_Config.Switches (Index).Boolean_Output.all :=
Local_Config.Switches (Index).Boolean_Value;
return;
when Switch_Integer =>
begin
if Parameter = "" then
Local_Config.Switches (Index).Integer_Output.all :=
Local_Config.Switches (Index).Integer_Default;
else
Local_Config.Switches (Index).Integer_Output.all :=
Integer'Value (Parameter);
end if;
exception
when Constraint_Error =>
raise Invalid_Parameter
with "Expected integer parameter for '"
& Switch & "'";
end;
return;
when Switch_String =>
Free (Local_Config.Switches (Index).String_Output.all);
Local_Config.Switches (Index).String_Output.all :=
new String'(Parameter);
return;
when Switch_Callback =>
Local_Config.Switches (Index).Callback (Switch, Parameter);
return;
end case;
end if;
-- Otherwise calls the user callback if one was defined
if Callback /= null then
Callback (Switch => Switch,
Parameter => Parameter,
Section => Section_Name.all);
end if;
end Do_Callback;
procedure For_Each_Simple
is new For_Each_Simple_Switch (Simple_Callback);
---------------------
-- Simple_Callback --
---------------------
procedure Simple_Callback
(Simple_Switch : String;
Separator : String;
Parameter : String;
Index : Integer)
is
pragma Unreferenced (Separator);
begin
Do_Callback (Switch => Simple_Switch,
Parameter => Parameter,
Index => Index);
end Simple_Callback;
-- Start of processing for Getopt
begin
-- We work with a local copy of Config, because Config can be null, for
-- example if Define_Switch was never called. We could modify Config
-- itself, but then we would have to make it into an 'in out' parameter,
-- which would be incompatible.
if Local_Config = null then
Local_Config := new Command_Line_Configuration_Record;
end if;
if Local_Config.Switches = null then
Local_Config.Switches := new Switch_Definitions (1 .. 0);
end if;
-- Initialize sections
if Local_Config.Sections = null then
Local_Config.Sections := new Argument_List'(1 .. 0 => null);
end if;
Internal_Initialize_Option_Scan
(Parser => Parser,
Switch_Char => Parser.Switch_Character,
Stop_At_First_Non_Switch => Parser.Stop_At_First,
Section_Delimiters => Section_Delimiters (Local_Config));
Getopt_Switches := new String'
(Get_Switches (Local_Config, Parser.Switch_Character, Section_Name.all)
& " h -help");
-- Initialize output values for automatically handled switches
for S in Local_Config.Switches'Range loop
case Local_Config.Switches (S).Typ is
when Switch_Untyped | Switch_Callback =>
null; -- Nothing to do
when Switch_Boolean =>
Local_Config.Switches (S).Boolean_Output.all :=
not Local_Config.Switches (S).Boolean_Value;
when Switch_Integer =>
Local_Config.Switches (S).Integer_Output.all :=
Local_Config.Switches (S).Integer_Initial;
when Switch_String =>
if Local_Config.Switches (S).String_Output.all = null then
Local_Config.Switches (S).String_Output.all :=
new String'("");
end if;
end case;
end loop;
-- For all sections, and all switches within those sections
loop
C := Getopt (Switches => Getopt_Switches.all,
Concatenate => Concatenate,
Parser => Parser);
if C = '*' then
-- Full_Switch already includes the leading '-'
Do_Callback (Switch => Full_Switch (Parser),
Parameter => Parameter (Parser),
Index => -1);
elsif C /= ASCII.NUL then
if Full_Switch (Parser) = "h"
or else
Full_Switch (Parser) = "-help"
then
Display_Help (Local_Config);
raise Exit_From_Command_Line;
end if;
-- Do switch expansion if needed
For_Each_Simple
(Local_Config,
Section => Section_Name.all,
Switch => Parser.Switch_Character & Full_Switch (Parser),
Parameter => Parameter (Parser));
else
if Current_Section = -1 then
Current_Section := Local_Config.Sections'First;
else
Current_Section := Current_Section + 1;
end if;
exit when Current_Section > Local_Config.Sections'Last;
Section_Name := Local_Config.Sections (Current_Section);
Goto_Section (Section_Name.all, Parser);
Free (Getopt_Switches);
Getopt_Switches := new String'
(Get_Switches
(Local_Config, Parser.Switch_Character, Section_Name.all));
end if;
end loop;
Free (Getopt_Switches);
exception
when Invalid_Switch =>
Free (Getopt_Switches);
-- Message inspired by "ls" on Unix
if not Quiet then
Put_Line (Standard_Error,
Base_Name (Ada.Command_Line.Command_Name)
& ": unrecognized option '"
& Full_Switch (Parser)
& "'");
Try_Help;
end if;
raise;
when others =>
Free (Getopt_Switches);
raise;
end Getopt;
-----------
-- Build --
-----------
procedure Build
(Line : in out Command_Line;
Args : out GNAT.OS_Lib.Argument_List_Access;
Expanded : Boolean := False;
Switch_Char : Character := '-')
is
Iter : Command_Line_Iterator;
Count : Natural := 0;
begin
Start (Line, Iter, Expanded => Expanded);
while Has_More (Iter) loop
if Is_New_Section (Iter) then
Count := Count + 1;
end if;
Count := Count + 1;
Next (Iter);
end loop;
Args := new Argument_List (1 .. Count);
Count := Args'First;
Start (Line, Iter, Expanded => Expanded);
while Has_More (Iter) loop
if Is_New_Section (Iter) then
Args (Count) := new String'(Switch_Char & Current_Section (Iter));
Count := Count + 1;
end if;
Args (Count) := new String'(Current_Switch (Iter)
& Current_Separator (Iter)
& Current_Parameter (Iter));
Count := Count + 1;
Next (Iter);
end loop;
end Build;
--------------
-- Try_Help --
--------------
-- Note: Any change to the message displayed should also be done in
-- gnatbind.adb that does not use this interface.
procedure Try_Help is
begin
Put_Line
(Standard_Error,
"try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe")
& " --help"" for more information.");
end Try_Help;
end GNAT.Command_Line;