Mercurial > hg > CbC > CbC_gcc
view gcc/ada/libgnat/g-comlin.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line source
------------------------------------------------------------------------------ -- -- -- 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-2017, 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 -- -- <http://www.gnu.org/licenses/>. -- -- -- -- 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 begin 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 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 return String'(1 .. 0 => ' '); elsif Parser.Section (Parser.Current_Argument) = 0 then return Get_Argument (Do_Expansion); end if; Parser.Current_Argument := Parser.Current_Argument + 1; -- Could it be a file name with wild cards 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) = '*' or else Arg (Index) = '?' or else Arg (Index) = '[' then Parser.In_Expansion := True; Start_Expansion (Parser.Expansion_It, Arg); return Get_Argument (Do_Expansion, Parser); 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 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 <<Restart>> -- 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; 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 <switch>=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 <switch> 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; 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_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) 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; 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 => 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 Put_Line (Standard_Error, Base_Name (Ada.Command_Line.Command_Name) & ": unrecognized option '" & Full_Switch (Parser) & "'"); Try_Help; 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;