]> gcc.gnu.org Git - gcc.git/blob - gcc/ada/libgnat/g-comlin.adb
[Ada] Better exception message on Invalid_Switch exception
[gcc.git] / gcc / ada / libgnat / g-comlin.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . C O M M A N D _ L I N E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1999-2019, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Characters.Handling; use Ada.Characters.Handling;
33 with Ada.Strings.Unbounded;
34 with Ada.Text_IO; use Ada.Text_IO;
35 with Ada.Unchecked_Deallocation;
36
37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
38 with GNAT.OS_Lib; use GNAT.OS_Lib;
39
40 package body GNAT.Command_Line is
41
42 -- General note: this entire body could use much more commenting. There
43 -- are large sections of uncommented code throughout, and many formal
44 -- parameters of local subprograms are not documented at all ???
45
46 package CL renames Ada.Command_Line;
47
48 type Switch_Parameter_Type is
49 (Parameter_None,
50 Parameter_With_Optional_Space, -- ':' in getopt
51 Parameter_With_Space_Or_Equal, -- '=' in getopt
52 Parameter_No_Space, -- '!' in getopt
53 Parameter_Optional); -- '?' in getopt
54
55 procedure Set_Parameter
56 (Variable : out Parameter_Type;
57 Arg_Num : Positive;
58 First : Positive;
59 Last : Natural;
60 Extra : Character := ASCII.NUL);
61 pragma Inline (Set_Parameter);
62 -- Set the parameter that will be returned by Parameter below
63 --
64 -- Extra is a character that needs to be added when reporting Full_Switch.
65 -- (it will in general be the switch character, for instance '-').
66 -- Otherwise, Full_Switch will report 'f' instead of '-f'. In particular,
67 -- it needs to be set when reporting an invalid switch or handling '*'.
68 --
69 -- Parameters need to be defined ???
70
71 function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean;
72 -- Go to the next argument on the command line. If we are at the end of
73 -- the current section, we want to make sure there is no other identical
74 -- section on the command line (there might be multiple instances of
75 -- -largs). Returns True iff there is another argument.
76
77 function Get_File_Names_Case_Sensitive return Integer;
78 pragma Import (C, Get_File_Names_Case_Sensitive,
79 "__gnat_get_file_names_case_sensitive");
80
81 File_Names_Case_Sensitive : constant Boolean :=
82 Get_File_Names_Case_Sensitive /= 0;
83
84 procedure Canonical_Case_File_Name (S : in out String);
85 -- Given a file name, converts it to canonical case form. For systems where
86 -- file names are case sensitive, this procedure has no effect. If file
87 -- names are not case sensitive (i.e. for example if you have the file
88 -- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call
89 -- converts the given string to canonical all lower case form, so that two
90 -- file names compare equal if they refer to the same file.
91
92 procedure Internal_Initialize_Option_Scan
93 (Parser : Opt_Parser;
94 Switch_Char : Character;
95 Stop_At_First_Non_Switch : Boolean;
96 Section_Delimiters : String);
97 -- Initialize Parser, which must have been allocated already
98
99 function Argument (Parser : Opt_Parser; Index : Integer) return String;
100 -- Return the index-th command line argument
101
102 procedure Find_Longest_Matching_Switch
103 (Switches : String;
104 Arg : String;
105 Index_In_Switches : out Integer;
106 Switch_Length : out Integer;
107 Param : out Switch_Parameter_Type);
108 -- Return the Longest switch from Switches that at least partially matches
109 -- Arg. Index_In_Switches is set to 0 if none matches. What are other
110 -- parameters??? in particular Param is not always set???
111
112 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
113 (Argument_List, Argument_List_Access);
114
115 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
116 (Command_Line_Configuration_Record, Command_Line_Configuration);
117
118 procedure Remove (Line : in out Argument_List_Access; Index : Integer);
119 -- Remove a specific element from Line
120
121 procedure Add
122 (Line : in out Argument_List_Access;
123 Str : String_Access;
124 Before : Boolean := False);
125 -- Add a new element to Line. If Before is True, the item is inserted at
126 -- the beginning, else it is appended.
127
128 procedure Add
129 (Config : in out Command_Line_Configuration;
130 Switch : Switch_Definition);
131 procedure Add
132 (Def : in out Alias_Definitions_List;
133 Alias : Alias_Definition);
134 -- Add a new element to Def
135
136 procedure Initialize_Switch_Def
137 (Def : out Switch_Definition;
138 Switch : String := "";
139 Long_Switch : String := "";
140 Help : String := "";
141 Section : String := "";
142 Argument : String := "ARG");
143 -- Initialize [Def] with the contents of the other parameters.
144 -- This also checks consistency of the switch parameters, and will raise
145 -- Invalid_Switch if they do not match.
146
147 procedure Decompose_Switch
148 (Switch : String;
149 Parameter_Type : out Switch_Parameter_Type;
150 Switch_Last : out Integer);
151 -- Given a switch definition ("name:" for instance), extracts the type of
152 -- parameter that is expected, and the name of the switch
153
154 function Can_Have_Parameter (S : String) return Boolean;
155 -- True if S can have a parameter
156
157 function Require_Parameter (S : String) return Boolean;
158 -- True if S requires a parameter
159
160 function Actual_Switch (S : String) return String;
161 -- Remove any possible trailing '!', ':', '?' and '='
162
163 generic
164 with procedure Callback
165 (Simple_Switch : String;
166 Separator : String;
167 Parameter : String;
168 Index : Integer); -- Index in Config.Switches, or -1
169 procedure For_Each_Simple_Switch
170 (Config : Command_Line_Configuration;
171 Section : String;
172 Switch : String;
173 Parameter : String := "";
174 Unalias : Boolean := True);
175 -- Breaks Switch into as simple switches as possible (expanding aliases and
176 -- ungrouping common prefixes when possible), and call Callback for each of
177 -- these.
178
179 procedure Sort_Sections
180 (Line : not null GNAT.OS_Lib.Argument_List_Access;
181 Sections : GNAT.OS_Lib.Argument_List_Access;
182 Params : GNAT.OS_Lib.Argument_List_Access);
183 -- Reorder the command line switches so that the switches belonging to a
184 -- section are grouped together.
185
186 procedure Group_Switches
187 (Cmd : Command_Line;
188 Result : Argument_List_Access;
189 Sections : Argument_List_Access;
190 Params : Argument_List_Access);
191 -- Group switches with common prefixes whenever possible. Once they have
192 -- been grouped, we also check items for possible aliasing.
193
194 procedure Alias_Switches
195 (Cmd : Command_Line;
196 Result : Argument_List_Access;
197 Params : Argument_List_Access);
198 -- When possible, replace one or more switches by an alias, i.e. a shorter
199 -- version.
200
201 function Looking_At
202 (Type_Str : String;
203 Index : Natural;
204 Substring : String) return Boolean;
205 -- Return True if the characters starting at Index in Type_Str are
206 -- equivalent to Substring.
207
208 generic
209 with function Callback (S : String; Index : Integer) return Boolean;
210 procedure Foreach_Switch
211 (Config : Command_Line_Configuration;
212 Section : String);
213 -- Iterate over all switches defined in Config, for a specific section.
214 -- Index is set to the index in Config.Switches. Stop iterating when
215 -- Callback returns False.
216
217 --------------
218 -- Argument --
219 --------------
220
221 function Argument (Parser : Opt_Parser; Index : Integer) return String is
222 begin
223 if Parser.Arguments /= null then
224 return Parser.Arguments (Index + Parser.Arguments'First - 1).all;
225 else
226 return CL.Argument (Index);
227 end if;
228 end Argument;
229
230 ------------------------------
231 -- Canonical_Case_File_Name --
232 ------------------------------
233
234 procedure Canonical_Case_File_Name (S : in out String) is
235 begin
236 if not File_Names_Case_Sensitive then
237 for J in S'Range loop
238 if S (J) in 'A' .. 'Z' then
239 S (J) := Character'Val
240 (Character'Pos (S (J)) +
241 (Character'Pos ('a') - Character'Pos ('A')));
242 end if;
243 end loop;
244 end if;
245 end Canonical_Case_File_Name;
246
247 ---------------
248 -- Expansion --
249 ---------------
250
251 function Expansion (Iterator : Expansion_Iterator) return String is
252 type Pointer is access all Expansion_Iterator;
253
254 It : constant Pointer := Iterator'Unrestricted_Access;
255 S : String (1 .. 1024);
256 Last : Natural;
257
258 Current : Depth := It.Current_Depth;
259 NL : Positive;
260
261 begin
262 -- It is assumed that a directory is opened at the current level.
263 -- Otherwise GNAT.Directory_Operations.Directory_Error will be raised
264 -- at the first call to Read.
265
266 loop
267 Read (It.Levels (Current).Dir, S, Last);
268
269 -- If we have exhausted the directory, close it and go back one level
270
271 if Last = 0 then
272 Close (It.Levels (Current).Dir);
273
274 -- If we are at level 1, we are finished; return an empty string
275
276 if Current = 1 then
277 return String'(1 .. 0 => ' ');
278
279 -- Otherwise continue with the directory at the previous level
280
281 else
282 Current := Current - 1;
283 It.Current_Depth := Current;
284 end if;
285
286 -- If this is a directory, that is neither "." or "..", attempt to
287 -- go to the next level.
288
289 elsif Is_Directory
290 (It.Dir_Name (1 .. It.Levels (Current).Name_Last) &
291 S (1 .. Last))
292 and then S (1 .. Last) /= "."
293 and then S (1 .. Last) /= ".."
294 then
295 -- We can go to the next level only if we have not reached the
296 -- maximum depth,
297
298 if Current < It.Maximum_Depth then
299 NL := It.Levels (Current).Name_Last;
300
301 -- And if relative path of this new directory is not too long
302
303 if NL + Last + 1 < Max_Path_Length then
304 Current := Current + 1;
305 It.Current_Depth := Current;
306 It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last);
307 NL := NL + Last + 1;
308 It.Dir_Name (NL) := Directory_Separator;
309 It.Levels (Current).Name_Last := NL;
310 Canonical_Case_File_Name (It.Dir_Name (1 .. NL));
311
312 -- Open the new directory, and read from it
313
314 GNAT.Directory_Operations.Open
315 (It.Levels (Current).Dir, It.Dir_Name (1 .. NL));
316 end if;
317 end if;
318 end if;
319
320 -- Check the relative path against the pattern
321
322 -- Note that we try to match also against directory names, since
323 -- clients of this function may expect to retrieve directories.
324
325 declare
326 Name : String :=
327 It.Dir_Name (It.Start .. It.Levels (Current).Name_Last)
328 & S (1 .. Last);
329
330 begin
331 Canonical_Case_File_Name (Name);
332
333 -- If it matches return the relative path
334
335 if GNAT.Regexp.Match (Name, Iterator.Regexp) then
336 return Name;
337 end if;
338 end;
339 end loop;
340 end Expansion;
341
342 ---------------------
343 -- Current_Section --
344 ---------------------
345
346 function Current_Section
347 (Parser : Opt_Parser := Command_Line_Parser) return String
348 is
349 begin
350 if Parser.Current_Section = 1 then
351 return "";
352 end if;
353
354 for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1,
355 Parser.Section'Last)
356 loop
357 if Parser.Section (Index) = 0 then
358 return Argument (Parser, Index);
359 end if;
360 end loop;
361
362 return "";
363 end Current_Section;
364
365 -----------------
366 -- Full_Switch --
367 -----------------
368
369 function Full_Switch
370 (Parser : Opt_Parser := Command_Line_Parser) return String
371 is
372 begin
373 if Parser.The_Switch.Extra = ASCII.NUL then
374 return Argument (Parser, Parser.The_Switch.Arg_Num)
375 (Parser.The_Switch.First .. Parser.The_Switch.Last);
376 else
377 return Parser.The_Switch.Extra
378 & Argument (Parser, Parser.The_Switch.Arg_Num)
379 (Parser.The_Switch.First .. Parser.The_Switch.Last);
380 end if;
381 end Full_Switch;
382
383 ------------------
384 -- Get_Argument --
385 ------------------
386
387 function Get_Argument
388 (Do_Expansion : Boolean := False;
389 Parser : Opt_Parser := Command_Line_Parser) return String
390 is
391 begin
392 if Parser.In_Expansion then
393 declare
394 S : constant String := Expansion (Parser.Expansion_It);
395 begin
396 if S'Length /= 0 then
397 return S;
398 else
399 Parser.In_Expansion := False;
400 end if;
401 end;
402 end if;
403
404 if Parser.Current_Argument > Parser.Arg_Count then
405
406 -- If this is the first time this function is called
407
408 if Parser.Current_Index = 1 then
409 Parser.Current_Argument := 1;
410 while Parser.Current_Argument <= Parser.Arg_Count
411 and then Parser.Section (Parser.Current_Argument) /=
412 Parser.Current_Section
413 loop
414 Parser.Current_Argument := Parser.Current_Argument + 1;
415 end loop;
416
417 else
418 return String'(1 .. 0 => ' ');
419 end if;
420
421 elsif Parser.Section (Parser.Current_Argument) = 0 then
422 while Parser.Current_Argument <= Parser.Arg_Count
423 and then Parser.Section (Parser.Current_Argument) /=
424 Parser.Current_Section
425 loop
426 Parser.Current_Argument := Parser.Current_Argument + 1;
427 end loop;
428 end if;
429
430 Parser.Current_Index := Integer'Last;
431
432 while Parser.Current_Argument <= Parser.Arg_Count
433 and then Parser.Is_Switch (Parser.Current_Argument)
434 loop
435 Parser.Current_Argument := Parser.Current_Argument + 1;
436 end loop;
437
438 if Parser.Current_Argument > Parser.Arg_Count then
439 return String'(1 .. 0 => ' ');
440 elsif Parser.Section (Parser.Current_Argument) = 0 then
441 return Get_Argument (Do_Expansion);
442 end if;
443
444 Parser.Current_Argument := Parser.Current_Argument + 1;
445
446 -- Could it be a file name with wildcards to expand?
447
448 if Do_Expansion then
449 declare
450 Arg : constant String :=
451 Argument (Parser, Parser.Current_Argument - 1);
452 begin
453 for Index in Arg'Range loop
454 if Arg (Index) = '*'
455 or else Arg (Index) = '?'
456 or else Arg (Index) = '['
457 then
458 Parser.In_Expansion := True;
459 Start_Expansion (Parser.Expansion_It, Arg);
460 return Get_Argument (Do_Expansion, Parser);
461 end if;
462 end loop;
463 end;
464 end if;
465
466 return Argument (Parser, Parser.Current_Argument - 1);
467 end Get_Argument;
468
469 ----------------------
470 -- Decompose_Switch --
471 ----------------------
472
473 procedure Decompose_Switch
474 (Switch : String;
475 Parameter_Type : out Switch_Parameter_Type;
476 Switch_Last : out Integer)
477 is
478 begin
479 if Switch = "" then
480 Parameter_Type := Parameter_None;
481 Switch_Last := Switch'Last;
482 return;
483 end if;
484
485 case Switch (Switch'Last) is
486 when ':' =>
487 Parameter_Type := Parameter_With_Optional_Space;
488 Switch_Last := Switch'Last - 1;
489
490 when '=' =>
491 Parameter_Type := Parameter_With_Space_Or_Equal;
492 Switch_Last := Switch'Last - 1;
493
494 when '!' =>
495 Parameter_Type := Parameter_No_Space;
496 Switch_Last := Switch'Last - 1;
497
498 when '?' =>
499 Parameter_Type := Parameter_Optional;
500 Switch_Last := Switch'Last - 1;
501
502 when others =>
503 Parameter_Type := Parameter_None;
504 Switch_Last := Switch'Last;
505 end case;
506 end Decompose_Switch;
507
508 ----------------------------------
509 -- Find_Longest_Matching_Switch --
510 ----------------------------------
511
512 procedure Find_Longest_Matching_Switch
513 (Switches : String;
514 Arg : String;
515 Index_In_Switches : out Integer;
516 Switch_Length : out Integer;
517 Param : out Switch_Parameter_Type)
518 is
519 Index : Natural;
520 Length : Natural := 1;
521 Last : Natural;
522 P : Switch_Parameter_Type;
523
524 begin
525 Index_In_Switches := 0;
526 Switch_Length := 0;
527
528 -- Remove all leading spaces first to make sure that Index points
529 -- at the start of the first switch.
530
531 Index := Switches'First;
532 while Index <= Switches'Last and then Switches (Index) = ' ' loop
533 Index := Index + 1;
534 end loop;
535
536 while Index <= Switches'Last loop
537
538 -- Search the length of the parameter at this position in Switches
539
540 Length := Index;
541 while Length <= Switches'Last
542 and then Switches (Length) /= ' '
543 loop
544 Length := Length + 1;
545 end loop;
546
547 -- Length now marks the separator after the current switch. Last will
548 -- mark the last character of the name of the switch.
549
550 if Length = Index + 1 then
551 P := Parameter_None;
552 Last := Index;
553 else
554 Decompose_Switch (Switches (Index .. Length - 1), P, Last);
555 end if;
556
557 -- If it is the one we searched, it may be a candidate
558
559 if Arg'First + Last - Index <= Arg'Last
560 and then Switches (Index .. Last) =
561 Arg (Arg'First .. Arg'First + Last - Index)
562 and then Last - Index + 1 > Switch_Length
563 and then
564 (P /= Parameter_With_Space_Or_Equal
565 or else Arg'Last = Arg'First + Last - Index
566 or else Arg (Arg'First + Last - Index + 1) = '=')
567 then
568 Param := P;
569 Index_In_Switches := Index;
570 Switch_Length := Last - Index + 1;
571 end if;
572
573 -- Look for the next switch in Switches
574
575 while Index <= Switches'Last
576 and then Switches (Index) /= ' '
577 loop
578 Index := Index + 1;
579 end loop;
580
581 Index := Index + 1;
582 end loop;
583 end Find_Longest_Matching_Switch;
584
585 ------------
586 -- Getopt --
587 ------------
588
589 function Getopt
590 (Switches : String;
591 Concatenate : Boolean := True;
592 Parser : Opt_Parser := Command_Line_Parser) return Character
593 is
594 Dummy : Boolean;
595
596 begin
597 <<Restart>>
598
599 -- If we have finished parsing the current command line item (there
600 -- might be multiple switches in a single item), then go to the next
601 -- element.
602
603 if Parser.Current_Argument > Parser.Arg_Count
604 or else (Parser.Current_Index >
605 Argument (Parser, Parser.Current_Argument)'Last
606 and then not Goto_Next_Argument_In_Section (Parser))
607 then
608 return ASCII.NUL;
609 end if;
610
611 -- By default, the switch will not have a parameter
612
613 Parser.The_Parameter :=
614 (Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL);
615 Parser.The_Separator := ASCII.NUL;
616
617 declare
618 Arg : constant String :=
619 Argument (Parser, Parser.Current_Argument);
620 Index_Switches : Natural := 0;
621 Max_Length : Natural := 0;
622 End_Index : Natural;
623 Param : Switch_Parameter_Type;
624 begin
625 -- If we are on a new item, test if this might be a switch
626
627 if Parser.Current_Index = Arg'First then
628 if Arg = "" or else Arg (Arg'First) /= Parser.Switch_Character then
629
630 -- If it isn't a switch, return it immediately. We also know it
631 -- isn't the parameter to a previous switch, since that has
632 -- already been handled.
633
634 if Switches (Switches'First) = '*' then
635 Set_Parameter
636 (Parser.The_Switch,
637 Arg_Num => Parser.Current_Argument,
638 First => Arg'First,
639 Last => Arg'Last);
640 Parser.Is_Switch (Parser.Current_Argument) := True;
641 Dummy := Goto_Next_Argument_In_Section (Parser);
642 return '*';
643 end if;
644
645 if Parser.Stop_At_First then
646 Parser.Current_Argument := Positive'Last;
647 return ASCII.NUL;
648
649 elsif not Goto_Next_Argument_In_Section (Parser) then
650 return ASCII.NUL;
651
652 else
653 -- Recurse to get the next switch on the command line
654
655 goto Restart;
656 end if;
657 end if;
658
659 -- We are on the first character of a new command line argument,
660 -- which starts with Switch_Character. Further analysis is needed.
661
662 Parser.Current_Index := Parser.Current_Index + 1;
663 Parser.Is_Switch (Parser.Current_Argument) := True;
664 end if;
665
666 Find_Longest_Matching_Switch
667 (Switches => Switches,
668 Arg => Arg (Parser.Current_Index .. Arg'Last),
669 Index_In_Switches => Index_Switches,
670 Switch_Length => Max_Length,
671 Param => Param);
672
673 -- If switch is not accepted, it is either invalid or is returned
674 -- in the context of '*'.
675
676 if Index_Switches = 0 then
677
678 -- Find the current switch that we did not recognize. This is in
679 -- fact difficult because Getopt does not know explicitly about
680 -- short and long switches. Ideally, we would want the following
681 -- behavior:
682
683 -- * for short switches, with Concatenate:
684 -- if -a is not recognized, and the command line has -daf
685 -- we should report the invalid switch as "-a".
686
687 -- * for short switches, wihtout Concatenate:
688 -- we should report the invalid switch as "-daf".
689
690 -- * for long switches:
691 -- if the commadn line is "--long" we should report --long
692 -- as unrecongized.
693
694 -- Unfortunately, the fact that long switches start with a
695 -- duplicate switch character is just a convention (so we could
696 -- have a long switch "-long" for instance). We'll still rely on
697 -- this convention here to try and get as helpful an error message
698 -- as possible.
699
700 -- Long switch case (starting with double switch character)
701
702 if Arg (Arg'First + 1) = Parser.Switch_Character then
703 End_Index := Arg'Last;
704
705 -- Short switch case
706
707 else
708 End_Index :=
709 (if Concatenate then Parser.Current_Index else Arg'Last);
710 end if;
711
712 if Switches /= "" and then Switches (Switches'First) = '*' then
713
714 -- Always prepend the switch character, so that users know
715 -- that this comes from a switch on the command line. This
716 -- is especially important when Concatenate is False, since
717 -- otherwise the current argument first character is lost.
718
719 if Parser.Section (Parser.Current_Argument) = 0 then
720
721 -- A section transition should not be returned to the user
722
723 Dummy := Goto_Next_Argument_In_Section (Parser);
724 goto Restart;
725
726 else
727 Set_Parameter
728 (Parser.The_Switch,
729 Arg_Num => Parser.Current_Argument,
730 First => Parser.Current_Index,
731 Last => Arg'Last,
732 Extra => Parser.Switch_Character);
733 Parser.Is_Switch (Parser.Current_Argument) := True;
734 Dummy := Goto_Next_Argument_In_Section (Parser);
735 return '*';
736 end if;
737 end if;
738
739 if Parser.Current_Index = Arg'First then
740 Set_Parameter
741 (Parser.The_Switch,
742 Arg_Num => Parser.Current_Argument,
743 First => Parser.Current_Index,
744 Last => End_Index);
745 else
746 Set_Parameter
747 (Parser.The_Switch,
748 Arg_Num => Parser.Current_Argument,
749 First => Parser.Current_Index,
750 Last => End_Index,
751 Extra => Parser.Switch_Character);
752 end if;
753
754 Parser.Current_Index := End_Index + 1;
755
756 raise Invalid_Switch with
757 "Unrecognized option '" & Full_Switch (Parser) & ''';
758 end if;
759
760 End_Index := Parser.Current_Index + Max_Length - 1;
761 Set_Parameter
762 (Parser.The_Switch,
763 Arg_Num => Parser.Current_Argument,
764 First => Parser.Current_Index,
765 Last => End_Index);
766
767 case Param is
768 when Parameter_With_Optional_Space =>
769 if End_Index < Arg'Last then
770 Set_Parameter
771 (Parser.The_Parameter,
772 Arg_Num => Parser.Current_Argument,
773 First => End_Index + 1,
774 Last => Arg'Last);
775 Dummy := Goto_Next_Argument_In_Section (Parser);
776
777 elsif Parser.Current_Argument < Parser.Arg_Count
778 and then Parser.Section (Parser.Current_Argument + 1) /= 0
779 then
780 Parser.Current_Argument := Parser.Current_Argument + 1;
781 Parser.The_Separator := ' ';
782 Set_Parameter
783 (Parser.The_Parameter,
784 Arg_Num => Parser.Current_Argument,
785 First => Argument (Parser, Parser.Current_Argument)'First,
786 Last => Argument (Parser, Parser.Current_Argument)'Last);
787 Parser.Is_Switch (Parser.Current_Argument) := True;
788 Dummy := Goto_Next_Argument_In_Section (Parser);
789
790 else
791 Parser.Current_Index := End_Index + 1;
792 raise Invalid_Parameter;
793 end if;
794
795 when Parameter_With_Space_Or_Equal =>
796
797 -- If the switch is of the form <switch>=xxx
798
799 if End_Index < Arg'Last then
800 if Arg (End_Index + 1) = '='
801 and then End_Index + 1 < Arg'Last
802 then
803 Parser.The_Separator := '=';
804 Set_Parameter
805 (Parser.The_Parameter,
806 Arg_Num => Parser.Current_Argument,
807 First => End_Index + 2,
808 Last => Arg'Last);
809 Dummy := Goto_Next_Argument_In_Section (Parser);
810
811 else
812 Parser.Current_Index := End_Index + 1;
813 raise Invalid_Parameter;
814 end if;
815
816 -- Case of switch of the form <switch> xxx
817
818 elsif Parser.Current_Argument < Parser.Arg_Count
819 and then Parser.Section (Parser.Current_Argument + 1) /= 0
820 then
821 Parser.Current_Argument := Parser.Current_Argument + 1;
822 Parser.The_Separator := ' ';
823 Set_Parameter
824 (Parser.The_Parameter,
825 Arg_Num => Parser.Current_Argument,
826 First => Argument (Parser, Parser.Current_Argument)'First,
827 Last => Argument (Parser, Parser.Current_Argument)'Last);
828 Parser.Is_Switch (Parser.Current_Argument) := True;
829 Dummy := Goto_Next_Argument_In_Section (Parser);
830
831 else
832 Parser.Current_Index := End_Index + 1;
833 raise Invalid_Parameter;
834 end if;
835
836 when Parameter_No_Space =>
837 if End_Index < Arg'Last then
838 Set_Parameter
839 (Parser.The_Parameter,
840 Arg_Num => Parser.Current_Argument,
841 First => End_Index + 1,
842 Last => Arg'Last);
843 Dummy := Goto_Next_Argument_In_Section (Parser);
844
845 else
846 Parser.Current_Index := End_Index + 1;
847 raise Invalid_Parameter;
848 end if;
849
850 when Parameter_Optional =>
851 if End_Index < Arg'Last then
852 Set_Parameter
853 (Parser.The_Parameter,
854 Arg_Num => Parser.Current_Argument,
855 First => End_Index + 1,
856 Last => Arg'Last);
857 end if;
858
859 Dummy := Goto_Next_Argument_In_Section (Parser);
860
861 when Parameter_None =>
862 if Concatenate or else End_Index = Arg'Last then
863 Parser.Current_Index := End_Index + 1;
864
865 else
866 -- If Concatenate is False and the full argument is not
867 -- recognized as a switch, this is an invalid switch.
868
869 if Switches (Switches'First) = '*' then
870 Set_Parameter
871 (Parser.The_Switch,
872 Arg_Num => Parser.Current_Argument,
873 First => Arg'First,
874 Last => Arg'Last);
875 Parser.Is_Switch (Parser.Current_Argument) := True;
876 Dummy := Goto_Next_Argument_In_Section (Parser);
877 return '*';
878 end if;
879
880 Set_Parameter
881 (Parser.The_Switch,
882 Arg_Num => Parser.Current_Argument,
883 First => Parser.Current_Index,
884 Last => Arg'Last,
885 Extra => Parser.Switch_Character);
886 Parser.Current_Index := Arg'Last + 1;
887 raise Invalid_Switch with
888 "Unrecognized option '" & Full_Switch (Parser) & ''';
889 end if;
890 end case;
891
892 return Switches (Index_Switches);
893 end;
894 end Getopt;
895
896 -----------------------------------
897 -- Goto_Next_Argument_In_Section --
898 -----------------------------------
899
900 function Goto_Next_Argument_In_Section
901 (Parser : Opt_Parser) return Boolean
902 is
903 begin
904 Parser.Current_Argument := Parser.Current_Argument + 1;
905
906 if Parser.Current_Argument > Parser.Arg_Count
907 or else Parser.Section (Parser.Current_Argument) = 0
908 then
909 loop
910 Parser.Current_Argument := Parser.Current_Argument + 1;
911
912 if Parser.Current_Argument > Parser.Arg_Count then
913 Parser.Current_Index := 1;
914 return False;
915 end if;
916
917 exit when Parser.Section (Parser.Current_Argument) =
918 Parser.Current_Section;
919 end loop;
920 end if;
921
922 Parser.Current_Index :=
923 Argument (Parser, Parser.Current_Argument)'First;
924
925 return True;
926 end Goto_Next_Argument_In_Section;
927
928 ------------------
929 -- Goto_Section --
930 ------------------
931
932 procedure Goto_Section
933 (Name : String := "";
934 Parser : Opt_Parser := Command_Line_Parser)
935 is
936 Index : Integer;
937
938 begin
939 Parser.In_Expansion := False;
940
941 if Name = "" then
942 Parser.Current_Argument := 1;
943 Parser.Current_Index := 1;
944 Parser.Current_Section := 1;
945 return;
946 end if;
947
948 Index := 1;
949 while Index <= Parser.Arg_Count loop
950 if Parser.Section (Index) = 0
951 and then Argument (Parser, Index) = Parser.Switch_Character & Name
952 then
953 Parser.Current_Argument := Index + 1;
954 Parser.Current_Index := 1;
955
956 if Parser.Current_Argument <= Parser.Arg_Count then
957 Parser.Current_Section :=
958 Parser.Section (Parser.Current_Argument);
959 end if;
960
961 -- Exit from loop if we have the start of another section
962
963 if Index = Parser.Section'Last
964 or else Parser.Section (Index + 1) /= 0
965 then
966 return;
967 end if;
968 end if;
969
970 Index := Index + 1;
971 end loop;
972
973 Parser.Current_Argument := Positive'Last;
974 Parser.Current_Index := 2; -- so that Get_Argument returns nothing
975 end Goto_Section;
976
977 ----------------------------
978 -- Initialize_Option_Scan --
979 ----------------------------
980
981 procedure Initialize_Option_Scan
982 (Switch_Char : Character := '-';
983 Stop_At_First_Non_Switch : Boolean := False;
984 Section_Delimiters : String := "")
985 is
986 begin
987 Internal_Initialize_Option_Scan
988 (Parser => Command_Line_Parser,
989 Switch_Char => Switch_Char,
990 Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
991 Section_Delimiters => Section_Delimiters);
992 end Initialize_Option_Scan;
993
994 ----------------------------
995 -- Initialize_Option_Scan --
996 ----------------------------
997
998 procedure Initialize_Option_Scan
999 (Parser : out Opt_Parser;
1000 Command_Line : GNAT.OS_Lib.Argument_List_Access;
1001 Switch_Char : Character := '-';
1002 Stop_At_First_Non_Switch : Boolean := False;
1003 Section_Delimiters : String := "")
1004 is
1005 begin
1006 Free (Parser);
1007
1008 if Command_Line = null then
1009 Parser := new Opt_Parser_Data (CL.Argument_Count);
1010 Internal_Initialize_Option_Scan
1011 (Parser => Parser,
1012 Switch_Char => Switch_Char,
1013 Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
1014 Section_Delimiters => Section_Delimiters);
1015 else
1016 Parser := new Opt_Parser_Data (Command_Line'Length);
1017 Parser.Arguments := Command_Line;
1018 Internal_Initialize_Option_Scan
1019 (Parser => Parser,
1020 Switch_Char => Switch_Char,
1021 Stop_At_First_Non_Switch => Stop_At_First_Non_Switch,
1022 Section_Delimiters => Section_Delimiters);
1023 end if;
1024 end Initialize_Option_Scan;
1025
1026 -------------------------------------
1027 -- Internal_Initialize_Option_Scan --
1028 -------------------------------------
1029
1030 procedure Internal_Initialize_Option_Scan
1031 (Parser : Opt_Parser;
1032 Switch_Char : Character;
1033 Stop_At_First_Non_Switch : Boolean;
1034 Section_Delimiters : String)
1035 is
1036 Section_Num : Section_Number;
1037 Section_Index : Integer;
1038 Last : Integer;
1039 Delimiter_Found : Boolean;
1040
1041 Discard : Boolean;
1042 pragma Warnings (Off, Discard);
1043
1044 begin
1045 Parser.Current_Argument := 0;
1046 Parser.Current_Index := 0;
1047 Parser.In_Expansion := False;
1048 Parser.Switch_Character := Switch_Char;
1049 Parser.Stop_At_First := Stop_At_First_Non_Switch;
1050 Parser.Section := (others => 1);
1051
1052 -- If we are using sections, we have to preprocess the command line to
1053 -- delimit them. A section can be repeated, so we just give each item
1054 -- on the command line a section number
1055
1056 Section_Num := 1;
1057 Section_Index := Section_Delimiters'First;
1058 while Section_Index <= Section_Delimiters'Last loop
1059 Last := Section_Index;
1060 while Last <= Section_Delimiters'Last
1061 and then Section_Delimiters (Last) /= ' '
1062 loop
1063 Last := Last + 1;
1064 end loop;
1065
1066 Delimiter_Found := False;
1067 Section_Num := Section_Num + 1;
1068
1069 for Index in 1 .. Parser.Arg_Count loop
1070 pragma Assert (Argument (Parser, Index)'First = 1);
1071 if Argument (Parser, Index) /= ""
1072 and then Argument (Parser, Index)(1) = Parser.Switch_Character
1073 and then
1074 Argument (Parser, Index) = Parser.Switch_Character &
1075 Section_Delimiters
1076 (Section_Index .. Last - 1)
1077 then
1078 Parser.Section (Index) := 0;
1079 Delimiter_Found := True;
1080
1081 elsif Parser.Section (Index) = 0 then
1082
1083 -- A previous section delimiter
1084
1085 Delimiter_Found := False;
1086
1087 elsif Delimiter_Found then
1088 Parser.Section (Index) := Section_Num;
1089 end if;
1090 end loop;
1091
1092 Section_Index := Last + 1;
1093 while Section_Index <= Section_Delimiters'Last
1094 and then Section_Delimiters (Section_Index) = ' '
1095 loop
1096 Section_Index := Section_Index + 1;
1097 end loop;
1098 end loop;
1099
1100 Discard := Goto_Next_Argument_In_Section (Parser);
1101 end Internal_Initialize_Option_Scan;
1102
1103 ---------------
1104 -- Parameter --
1105 ---------------
1106
1107 function Parameter
1108 (Parser : Opt_Parser := Command_Line_Parser) return String
1109 is
1110 begin
1111 if Parser.The_Parameter.First > Parser.The_Parameter.Last then
1112 return String'(1 .. 0 => ' ');
1113 else
1114 return Argument (Parser, Parser.The_Parameter.Arg_Num)
1115 (Parser.The_Parameter.First .. Parser.The_Parameter.Last);
1116 end if;
1117 end Parameter;
1118
1119 ---------------
1120 -- Separator --
1121 ---------------
1122
1123 function Separator
1124 (Parser : Opt_Parser := Command_Line_Parser) return Character
1125 is
1126 begin
1127 return Parser.The_Separator;
1128 end Separator;
1129
1130 -------------------
1131 -- Set_Parameter --
1132 -------------------
1133
1134 procedure Set_Parameter
1135 (Variable : out Parameter_Type;
1136 Arg_Num : Positive;
1137 First : Positive;
1138 Last : Natural;
1139 Extra : Character := ASCII.NUL)
1140 is
1141 begin
1142 Variable.Arg_Num := Arg_Num;
1143 Variable.First := First;
1144 Variable.Last := Last;
1145 Variable.Extra := Extra;
1146 end Set_Parameter;
1147
1148 ---------------------
1149 -- Start_Expansion --
1150 ---------------------
1151
1152 procedure Start_Expansion
1153 (Iterator : out Expansion_Iterator;
1154 Pattern : String;
1155 Directory : String := "";
1156 Basic_Regexp : Boolean := True)
1157 is
1158 Directory_Separator : Character;
1159 pragma Import (C, Directory_Separator, "__gnat_dir_separator");
1160
1161 First : Positive := Pattern'First;
1162 Pat : String := Pattern;
1163
1164 begin
1165 Canonical_Case_File_Name (Pat);
1166 Iterator.Current_Depth := 1;
1167
1168 -- If Directory is unspecified, use the current directory ("./" or ".\")
1169
1170 if Directory = "" then
1171 Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator;
1172 Iterator.Start := 3;
1173
1174 else
1175 Iterator.Dir_Name (1 .. Directory'Length) := Directory;
1176 Iterator.Start := Directory'Length + 1;
1177 Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length));
1178
1179 -- Make sure that the last character is a directory separator
1180
1181 if Directory (Directory'Last) /= Directory_Separator then
1182 Iterator.Dir_Name (Iterator.Start) := Directory_Separator;
1183 Iterator.Start := Iterator.Start + 1;
1184 end if;
1185 end if;
1186
1187 Iterator.Levels (1).Name_Last := Iterator.Start - 1;
1188
1189 -- Open the initial Directory, at depth 1
1190
1191 GNAT.Directory_Operations.Open
1192 (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1));
1193
1194 -- If in the current directory and the pattern starts with "./" or ".\",
1195 -- drop the "./" or ".\" from the pattern.
1196
1197 if Directory = "" and then Pat'Length > 2
1198 and then Pat (Pat'First) = '.'
1199 and then Pat (Pat'First + 1) = Directory_Separator
1200 then
1201 First := Pat'First + 2;
1202 end if;
1203
1204 Iterator.Regexp :=
1205 GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True);
1206
1207 Iterator.Maximum_Depth := 1;
1208
1209 -- Maximum_Depth is equal to 1 plus the number of directory separators
1210 -- in the pattern.
1211
1212 for Index in First .. Pat'Last loop
1213 if Pat (Index) = Directory_Separator then
1214 Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1;
1215 exit when Iterator.Maximum_Depth = Max_Depth;
1216 end if;
1217 end loop;
1218 end Start_Expansion;
1219
1220 ----------
1221 -- Free --
1222 ----------
1223
1224 procedure Free (Parser : in out Opt_Parser) is
1225 procedure Unchecked_Free is new
1226 Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser);
1227 begin
1228 if Parser /= null and then Parser /= Command_Line_Parser then
1229 Free (Parser.Arguments);
1230 Unchecked_Free (Parser);
1231 end if;
1232 end Free;
1233
1234 ------------------
1235 -- Define_Alias --
1236 ------------------
1237
1238 procedure Define_Alias
1239 (Config : in out Command_Line_Configuration;
1240 Switch : String;
1241 Expanded : String;
1242 Section : String := "")
1243 is
1244 Def : Alias_Definition;
1245
1246 begin
1247 if Config = null then
1248 Config := new Command_Line_Configuration_Record;
1249 end if;
1250
1251 Def.Alias := new String'(Switch);
1252 Def.Expansion := new String'(Expanded);
1253 Def.Section := new String'(Section);
1254 Add (Config.Aliases, Def);
1255 end Define_Alias;
1256
1257 -------------------
1258 -- Define_Prefix --
1259 -------------------
1260
1261 procedure Define_Prefix
1262 (Config : in out Command_Line_Configuration;
1263 Prefix : String)
1264 is
1265 begin
1266 if Config = null then
1267 Config := new Command_Line_Configuration_Record;
1268 end if;
1269
1270 Add (Config.Prefixes, new String'(Prefix));
1271 end Define_Prefix;
1272
1273 ---------
1274 -- Add --
1275 ---------
1276
1277 procedure Add
1278 (Config : in out Command_Line_Configuration;
1279 Switch : Switch_Definition)
1280 is
1281 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1282 (Switch_Definitions, Switch_Definitions_List);
1283
1284 Tmp : Switch_Definitions_List;
1285
1286 begin
1287 if Config = null then
1288 Config := new Command_Line_Configuration_Record;
1289 end if;
1290
1291 Tmp := Config.Switches;
1292
1293 if Tmp = null then
1294 Config.Switches := new Switch_Definitions (1 .. 1);
1295 else
1296 Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1);
1297 Config.Switches (1 .. Tmp'Length) := Tmp.all;
1298 Unchecked_Free (Tmp);
1299 end if;
1300
1301 if Switch.Switch /= null and then Switch.Switch.all = "*" then
1302 Config.Star_Switch := True;
1303 end if;
1304
1305 Config.Switches (Config.Switches'Last) := Switch;
1306 end Add;
1307
1308 ---------
1309 -- Add --
1310 ---------
1311
1312 procedure Add
1313 (Def : in out Alias_Definitions_List;
1314 Alias : Alias_Definition)
1315 is
1316 procedure Unchecked_Free is new
1317 Ada.Unchecked_Deallocation
1318 (Alias_Definitions, Alias_Definitions_List);
1319
1320 Tmp : Alias_Definitions_List := Def;
1321
1322 begin
1323 if Tmp = null then
1324 Def := new Alias_Definitions (1 .. 1);
1325 else
1326 Def := new Alias_Definitions (1 .. Tmp'Length + 1);
1327 Def (1 .. Tmp'Length) := Tmp.all;
1328 Unchecked_Free (Tmp);
1329 end if;
1330
1331 Def (Def'Last) := Alias;
1332 end Add;
1333
1334 ---------------------------
1335 -- Initialize_Switch_Def --
1336 ---------------------------
1337
1338 procedure Initialize_Switch_Def
1339 (Def : out Switch_Definition;
1340 Switch : String := "";
1341 Long_Switch : String := "";
1342 Help : String := "";
1343 Section : String := "";
1344 Argument : String := "ARG")
1345 is
1346 P1, P2 : Switch_Parameter_Type := Parameter_None;
1347 Last1, Last2 : Integer;
1348
1349 begin
1350 if Switch /= "" then
1351 Def.Switch := new String'(Switch);
1352 Decompose_Switch (Switch, P1, Last1);
1353 end if;
1354
1355 if Long_Switch /= "" then
1356 Def.Long_Switch := new String'(Long_Switch);
1357 Decompose_Switch (Long_Switch, P2, Last2);
1358 end if;
1359
1360 if Switch /= "" and then Long_Switch /= "" then
1361 if (P1 = Parameter_None and then P2 /= P1)
1362 or else (P2 = Parameter_None and then P1 /= P2)
1363 or else (P1 = Parameter_Optional and then P2 /= P1)
1364 or else (P2 = Parameter_Optional and then P2 /= P1)
1365 then
1366 raise Invalid_Switch
1367 with "Inconsistent parameter types for "
1368 & Switch & " and " & Long_Switch;
1369 end if;
1370 end if;
1371
1372 if Section /= "" then
1373 Def.Section := new String'(Section);
1374 end if;
1375
1376 if Argument /= "ARG" then
1377 Def.Argument := new String'(Argument);
1378 end if;
1379
1380 if Help /= "" then
1381 Def.Help := new String'(Help);
1382 end if;
1383 end Initialize_Switch_Def;
1384
1385 -------------------
1386 -- Define_Switch --
1387 -------------------
1388
1389 procedure Define_Switch
1390 (Config : in out Command_Line_Configuration;
1391 Switch : String := "";
1392 Long_Switch : String := "";
1393 Help : String := "";
1394 Section : String := "";
1395 Argument : String := "ARG")
1396 is
1397 Def : Switch_Definition;
1398 begin
1399 if Switch /= "" or else Long_Switch /= "" then
1400 Initialize_Switch_Def
1401 (Def, Switch, Long_Switch, Help, Section, Argument);
1402 Add (Config, Def);
1403 end if;
1404 end Define_Switch;
1405
1406 -------------------
1407 -- Define_Switch --
1408 -------------------
1409
1410 procedure Define_Switch
1411 (Config : in out Command_Line_Configuration;
1412 Output : access Boolean;
1413 Switch : String := "";
1414 Long_Switch : String := "";
1415 Help : String := "";
1416 Section : String := "";
1417 Value : Boolean := True)
1418 is
1419 Def : Switch_Definition (Switch_Boolean);
1420 begin
1421 if Switch /= "" or else Long_Switch /= "" then
1422 Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section);
1423 Def.Boolean_Output := Output.all'Unchecked_Access;
1424 Def.Boolean_Value := Value;
1425 Add (Config, Def);
1426 end if;
1427 end Define_Switch;
1428
1429 -------------------
1430 -- Define_Switch --
1431 -------------------
1432
1433 procedure Define_Switch
1434 (Config : in out Command_Line_Configuration;
1435 Output : access Integer;
1436 Switch : String := "";
1437 Long_Switch : String := "";
1438 Help : String := "";
1439 Section : String := "";
1440 Initial : Integer := 0;
1441 Default : Integer := 1;
1442 Argument : String := "ARG")
1443 is
1444 Def : Switch_Definition (Switch_Integer);
1445 begin
1446 if Switch /= "" or else Long_Switch /= "" then
1447 Initialize_Switch_Def
1448 (Def, Switch, Long_Switch, Help, Section, Argument);
1449 Def.Integer_Output := Output.all'Unchecked_Access;
1450 Def.Integer_Default := Default;
1451 Def.Integer_Initial := Initial;
1452 Add (Config, Def);
1453 end if;
1454 end Define_Switch;
1455
1456 -------------------
1457 -- Define_Switch --
1458 -------------------
1459
1460 procedure Define_Switch
1461 (Config : in out Command_Line_Configuration;
1462 Output : access GNAT.Strings.String_Access;
1463 Switch : String := "";
1464 Long_Switch : String := "";
1465 Help : String := "";
1466 Section : String := "";
1467 Argument : String := "ARG")
1468 is
1469 Def : Switch_Definition (Switch_String);
1470 begin
1471 if Switch /= "" or else Long_Switch /= "" then
1472 Initialize_Switch_Def
1473 (Def, Switch, Long_Switch, Help, Section, Argument);
1474 Def.String_Output := Output.all'Unchecked_Access;
1475 Add (Config, Def);
1476 end if;
1477 end Define_Switch;
1478
1479 -------------------
1480 -- Define_Switch --
1481 -------------------
1482
1483 procedure Define_Switch
1484 (Config : in out Command_Line_Configuration;
1485 Callback : not null Value_Callback;
1486 Switch : String := "";
1487 Long_Switch : String := "";
1488 Help : String := "";
1489 Section : String := "";
1490 Argument : String := "ARG")
1491 is
1492 Def : Switch_Definition (Switch_Callback);
1493 begin
1494 if Switch /= "" or else Long_Switch /= "" then
1495 Initialize_Switch_Def
1496 (Def, Switch, Long_Switch, Help, Section, Argument);
1497 Def.Callback := Callback;
1498 Add (Config, Def);
1499 end if;
1500 end Define_Switch;
1501
1502 --------------------
1503 -- Define_Section --
1504 --------------------
1505
1506 procedure Define_Section
1507 (Config : in out Command_Line_Configuration;
1508 Section : String)
1509 is
1510 begin
1511 if Config = null then
1512 Config := new Command_Line_Configuration_Record;
1513 end if;
1514
1515 Add (Config.Sections, new String'(Section));
1516 end Define_Section;
1517
1518 --------------------
1519 -- Foreach_Switch --
1520 --------------------
1521
1522 procedure Foreach_Switch
1523 (Config : Command_Line_Configuration;
1524 Section : String)
1525 is
1526 begin
1527 if Config /= null and then Config.Switches /= null then
1528 for J in Config.Switches'Range loop
1529 if (Section = "" and then Config.Switches (J).Section = null)
1530 or else
1531 (Config.Switches (J).Section /= null
1532 and then Config.Switches (J).Section.all = Section)
1533 then
1534 exit when Config.Switches (J).Switch /= null
1535 and then not Callback (Config.Switches (J).Switch.all, J);
1536
1537 exit when Config.Switches (J).Long_Switch /= null
1538 and then
1539 not Callback (Config.Switches (J).Long_Switch.all, J);
1540 end if;
1541 end loop;
1542 end if;
1543 end Foreach_Switch;
1544
1545 ------------------
1546 -- Get_Switches --
1547 ------------------
1548
1549 function Get_Switches
1550 (Config : Command_Line_Configuration;
1551 Switch_Char : Character := '-';
1552 Section : String := "") return String
1553 is
1554 Ret : Ada.Strings.Unbounded.Unbounded_String;
1555 use Ada.Strings.Unbounded;
1556
1557 function Add_Switch (S : String; Index : Integer) return Boolean;
1558 -- Add a switch to Ret
1559
1560 ----------------
1561 -- Add_Switch --
1562 ----------------
1563
1564 function Add_Switch (S : String; Index : Integer) return Boolean is
1565 pragma Unreferenced (Index);
1566 begin
1567 if S = "*" then
1568 Ret := "*" & Ret; -- Always first
1569 elsif S (S'First) = Switch_Char then
1570 Append (Ret, " " & S (S'First + 1 .. S'Last));
1571 else
1572 Append (Ret, " " & S);
1573 end if;
1574
1575 return True;
1576 end Add_Switch;
1577
1578 Tmp : Boolean;
1579 pragma Unreferenced (Tmp);
1580
1581 procedure Foreach is new Foreach_Switch (Add_Switch);
1582
1583 -- Start of processing for Get_Switches
1584
1585 begin
1586 if Config = null then
1587 return "";
1588 end if;
1589
1590 Foreach (Config, Section => Section);
1591
1592 -- Add relevant aliases
1593
1594 if Config.Aliases /= null then
1595 for A in Config.Aliases'Range loop
1596 if Config.Aliases (A).Section.all = Section then
1597 Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1);
1598 end if;
1599 end loop;
1600 end if;
1601
1602 return To_String (Ret);
1603 end Get_Switches;
1604
1605 ------------------------
1606 -- Section_Delimiters --
1607 ------------------------
1608
1609 function Section_Delimiters
1610 (Config : Command_Line_Configuration) return String
1611 is
1612 use Ada.Strings.Unbounded;
1613 Result : Unbounded_String;
1614
1615 begin
1616 if Config /= null and then Config.Sections /= null then
1617 for S in Config.Sections'Range loop
1618 Append (Result, " " & Config.Sections (S).all);
1619 end loop;
1620 end if;
1621
1622 return To_String (Result);
1623 end Section_Delimiters;
1624
1625 -----------------------
1626 -- Set_Configuration --
1627 -----------------------
1628
1629 procedure Set_Configuration
1630 (Cmd : in out Command_Line;
1631 Config : Command_Line_Configuration)
1632 is
1633 begin
1634 Cmd.Config := Config;
1635 end Set_Configuration;
1636
1637 -----------------------
1638 -- Get_Configuration --
1639 -----------------------
1640
1641 function Get_Configuration
1642 (Cmd : Command_Line) return Command_Line_Configuration
1643 is
1644 begin
1645 return Cmd.Config;
1646 end Get_Configuration;
1647
1648 ----------------------
1649 -- Set_Command_Line --
1650 ----------------------
1651
1652 procedure Set_Command_Line
1653 (Cmd : in out Command_Line;
1654 Switches : String;
1655 Getopt_Description : String := "";
1656 Switch_Char : Character := '-')
1657 is
1658 Tmp : Argument_List_Access;
1659 Parser : Opt_Parser;
1660 S : Character;
1661 Section : String_Access := null;
1662
1663 function Real_Full_Switch
1664 (S : Character;
1665 Parser : Opt_Parser) return String;
1666 -- Ensure that the returned switch value contains the Switch_Char prefix
1667 -- if needed.
1668
1669 ----------------------
1670 -- Real_Full_Switch --
1671 ----------------------
1672
1673 function Real_Full_Switch
1674 (S : Character;
1675 Parser : Opt_Parser) return String
1676 is
1677 begin
1678 if S = '*' then
1679 return Full_Switch (Parser);
1680 else
1681 return Switch_Char & Full_Switch (Parser);
1682 end if;
1683 end Real_Full_Switch;
1684
1685 -- Start of processing for Set_Command_Line
1686
1687 begin
1688 Free (Cmd.Expanded);
1689 Free (Cmd.Params);
1690
1691 if Switches /= "" then
1692 Tmp := Argument_String_To_List (Switches);
1693 Initialize_Option_Scan (Parser, Tmp, Switch_Char);
1694
1695 loop
1696 begin
1697 if Cmd.Config /= null then
1698
1699 -- Do not use Getopt_Description in this case. Otherwise,
1700 -- if we have defined a prefix -gnaty, and two switches
1701 -- -gnatya and -gnatyL!, we would have a different behavior
1702 -- depending on the order of switches:
1703
1704 -- -gnatyL1a => -gnatyL with argument "1a"
1705 -- -gnatyaL1 => -gnatya and -gnatyL with argument "1"
1706
1707 -- This is because the call to Getopt below knows nothing
1708 -- about prefixes, and in the first case finds a valid
1709 -- switch with arguments, so returns it without analyzing
1710 -- the argument. In the second case, the switch matches "*",
1711 -- and is then decomposed below.
1712
1713 -- Note: When a Command_Line object is associated with a
1714 -- Command_Line_Config (which is mostly the case for tools
1715 -- that let users choose the command line before spawning
1716 -- other tools, for instance IDEs), the configuration of
1717 -- the switches must be taken from the Command_Line_Config.
1718
1719 S := Getopt (Switches => "* " & Get_Switches (Cmd.Config),
1720 Concatenate => False,
1721 Parser => Parser);
1722
1723 else
1724 S := Getopt (Switches => "* " & Getopt_Description,
1725 Concatenate => False,
1726 Parser => Parser);
1727 end if;
1728
1729 exit when S = ASCII.NUL;
1730
1731 declare
1732 Sw : constant String := Real_Full_Switch (S, Parser);
1733 Is_Section : Boolean := False;
1734
1735 begin
1736 if Cmd.Config /= null
1737 and then Cmd.Config.Sections /= null
1738 then
1739 Section_Search :
1740 for S in Cmd.Config.Sections'Range loop
1741 if Sw = Cmd.Config.Sections (S).all then
1742 Section := Cmd.Config.Sections (S);
1743 Is_Section := True;
1744
1745 exit Section_Search;
1746 end if;
1747 end loop Section_Search;
1748 end if;
1749
1750 if not Is_Section then
1751 if Section = null then
1752 Add_Switch (Cmd, Sw, Parameter (Parser));
1753 else
1754 Add_Switch
1755 (Cmd, Sw, Parameter (Parser),
1756 Section => Section.all);
1757 end if;
1758 end if;
1759 end;
1760
1761 exception
1762 when Invalid_Parameter =>
1763
1764 -- Add it with no parameter, if that's the way the user
1765 -- wants it.
1766
1767 -- Specify the separator in all cases, as the switch might
1768 -- need to be unaliased, and the alias might contain
1769 -- switches with parameters.
1770
1771 if Section = null then
1772 Add_Switch
1773 (Cmd, Switch_Char & Full_Switch (Parser));
1774 else
1775 Add_Switch
1776 (Cmd, Switch_Char & Full_Switch (Parser),
1777 Section => Section.all);
1778 end if;
1779 end;
1780 end loop;
1781
1782 Free (Parser);
1783 end if;
1784 end Set_Command_Line;
1785
1786 ----------------
1787 -- Looking_At --
1788 ----------------
1789
1790 function Looking_At
1791 (Type_Str : String;
1792 Index : Natural;
1793 Substring : String) return Boolean
1794 is
1795 begin
1796 return Index + Substring'Length - 1 <= Type_Str'Last
1797 and then Type_Str (Index .. Index + Substring'Length - 1) = Substring;
1798 end Looking_At;
1799
1800 ------------------------
1801 -- Can_Have_Parameter --
1802 ------------------------
1803
1804 function Can_Have_Parameter (S : String) return Boolean is
1805 begin
1806 if S'Length <= 1 then
1807 return False;
1808 end if;
1809
1810 case S (S'Last) is
1811 when '!' | ':' | '?' | '=' =>
1812 return True;
1813 when others =>
1814 return False;
1815 end case;
1816 end Can_Have_Parameter;
1817
1818 -----------------------
1819 -- Require_Parameter --
1820 -----------------------
1821
1822 function Require_Parameter (S : String) return Boolean is
1823 begin
1824 if S'Length <= 1 then
1825 return False;
1826 end if;
1827
1828 case S (S'Last) is
1829 when '!' | ':' | '=' =>
1830 return True;
1831 when others =>
1832 return False;
1833 end case;
1834 end Require_Parameter;
1835
1836 -------------------
1837 -- Actual_Switch --
1838 -------------------
1839
1840 function Actual_Switch (S : String) return String is
1841 begin
1842 if S'Length <= 1 then
1843 return S;
1844 end if;
1845
1846 case S (S'Last) is
1847 when '!' | ':' | '?' | '=' =>
1848 return S (S'First .. S'Last - 1);
1849 when others =>
1850 return S;
1851 end case;
1852 end Actual_Switch;
1853
1854 ----------------------------
1855 -- For_Each_Simple_Switch --
1856 ----------------------------
1857
1858 procedure For_Each_Simple_Switch
1859 (Config : Command_Line_Configuration;
1860 Section : String;
1861 Switch : String;
1862 Parameter : String := "";
1863 Unalias : Boolean := True)
1864 is
1865 function Group_Analysis
1866 (Prefix : String;
1867 Group : String) return Boolean;
1868 -- Perform the analysis of a group of switches
1869
1870 Found_In_Config : Boolean := False;
1871 function Is_In_Config
1872 (Config_Switch : String; Index : Integer) return Boolean;
1873 -- If Switch is the same as Config_Switch, run the callback and sets
1874 -- Found_In_Config to True.
1875
1876 function Starts_With
1877 (Config_Switch : String; Index : Integer) return Boolean;
1878 -- if Switch starts with Config_Switch, sets Found_In_Config to True.
1879 -- The return value is for the Foreach_Switch iterator.
1880
1881 --------------------
1882 -- Group_Analysis --
1883 --------------------
1884
1885 function Group_Analysis
1886 (Prefix : String;
1887 Group : String) return Boolean
1888 is
1889 Idx : Natural;
1890 Found : Boolean;
1891
1892 function Analyze_Simple_Switch
1893 (Switch : String; Index : Integer) return Boolean;
1894 -- "Switches" is one of the switch definitions passed to the
1895 -- configuration, not one of the switches found on the command line.
1896
1897 ---------------------------
1898 -- Analyze_Simple_Switch --
1899 ---------------------------
1900
1901 function Analyze_Simple_Switch
1902 (Switch : String; Index : Integer) return Boolean
1903 is
1904 pragma Unreferenced (Index);
1905
1906 Full : constant String := Prefix & Group (Idx .. Group'Last);
1907
1908 Sw : constant String := Actual_Switch (Switch);
1909 -- Switches definition minus argument definition
1910
1911 Last : Natural;
1912 Param : Natural;
1913
1914 begin
1915 -- Verify that sw starts with Prefix
1916
1917 if Looking_At (Sw, Sw'First, Prefix)
1918
1919 -- Verify that the group starts with sw
1920
1921 and then Looking_At (Full, Full'First, Sw)
1922 then
1923 Last := Idx + Sw'Length - Prefix'Length - 1;
1924 Param := Last + 1;
1925
1926 if Can_Have_Parameter (Switch) then
1927
1928 -- Include potential parameter to the recursive call. Only
1929 -- numbers are allowed.
1930
1931 while Last < Group'Last
1932 and then Group (Last + 1) in '0' .. '9'
1933 loop
1934 Last := Last + 1;
1935 end loop;
1936 end if;
1937
1938 if not Require_Parameter (Switch) or else Last >= Param then
1939 if Idx = Group'First
1940 and then Last = Group'Last
1941 and then Last < Param
1942 then
1943 -- The group only concerns a single switch. Do not
1944 -- perform recursive call.
1945
1946 -- Note that we still perform a recursive call if
1947 -- a parameter is detected in the switch, as this
1948 -- is a way to correctly identify such a parameter
1949 -- in aliases.
1950
1951 return False;
1952 end if;
1953
1954 Found := True;
1955
1956 -- Recursive call, using the detected parameter if any
1957
1958 if Last >= Param then
1959 For_Each_Simple_Switch
1960 (Config,
1961 Section,
1962 Prefix & Group (Idx .. Param - 1),
1963 Group (Param .. Last));
1964
1965 else
1966 For_Each_Simple_Switch
1967 (Config, Section, Prefix & Group (Idx .. Last), "");
1968 end if;
1969
1970 Idx := Last + 1;
1971 return False;
1972 end if;
1973 end if;
1974
1975 return True;
1976 end Analyze_Simple_Switch;
1977
1978 procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch);
1979
1980 -- Start of processing for Group_Analysis
1981
1982 begin
1983 Idx := Group'First;
1984 while Idx <= Group'Last loop
1985 Found := False;
1986 Foreach (Config, Section);
1987
1988 if not Found then
1989 For_Each_Simple_Switch
1990 (Config, Section, Prefix & Group (Idx), "");
1991 Idx := Idx + 1;
1992 end if;
1993 end loop;
1994
1995 return True;
1996 end Group_Analysis;
1997
1998 ------------------
1999 -- Is_In_Config --
2000 ------------------
2001
2002 function Is_In_Config
2003 (Config_Switch : String; Index : Integer) return Boolean
2004 is
2005 Last : Natural;
2006 P : Switch_Parameter_Type;
2007
2008 begin
2009 Decompose_Switch (Config_Switch, P, Last);
2010
2011 if Config_Switch (Config_Switch'First .. Last) = Switch then
2012 case P is
2013 when Parameter_None =>
2014 if Parameter = "" then
2015 Callback (Switch, "", "", Index => Index);
2016 Found_In_Config := True;
2017 return False;
2018 end if;
2019
2020 when Parameter_With_Optional_Space =>
2021 Callback (Switch, " ", Parameter, Index => Index);
2022 Found_In_Config := True;
2023 return False;
2024
2025 when Parameter_With_Space_Or_Equal =>
2026 Callback (Switch, "=", Parameter, Index => Index);
2027 Found_In_Config := True;
2028 return False;
2029
2030 when Parameter_No_Space
2031 | Parameter_Optional
2032 =>
2033 Callback (Switch, "", Parameter, Index);
2034 Found_In_Config := True;
2035 return False;
2036 end case;
2037 end if;
2038
2039 return True;
2040 end Is_In_Config;
2041
2042 -----------------
2043 -- Starts_With --
2044 -----------------
2045
2046 function Starts_With
2047 (Config_Switch : String; Index : Integer) return Boolean
2048 is
2049 Last : Natural;
2050 Param : Natural;
2051 P : Switch_Parameter_Type;
2052
2053 begin
2054 -- This function is called when we believe the parameter was
2055 -- specified as part of the switch, instead of separately. Thus we
2056 -- look in the config to find all possible switches.
2057
2058 Decompose_Switch (Config_Switch, P, Last);
2059
2060 if Looking_At
2061 (Switch, Switch'First,
2062 Config_Switch (Config_Switch'First .. Last))
2063 then
2064 -- Set first char of Param, and last char of Switch
2065
2066 Param := Switch'First + Last;
2067 Last := Switch'First + Last - Config_Switch'First;
2068
2069 case P is
2070
2071 -- None is already handled in Is_In_Config
2072
2073 when Parameter_None =>
2074 null;
2075
2076 when Parameter_With_Space_Or_Equal =>
2077 if Param <= Switch'Last
2078 and then
2079 (Switch (Param) = ' ' or else Switch (Param) = '=')
2080 then
2081 Callback (Switch (Switch'First .. Last),
2082 "=", Switch (Param + 1 .. Switch'Last), Index);
2083 Found_In_Config := True;
2084 return False;
2085 end if;
2086
2087 when Parameter_With_Optional_Space =>
2088 if Param <= Switch'Last and then Switch (Param) = ' ' then
2089 Param := Param + 1;
2090 end if;
2091
2092 Callback (Switch (Switch'First .. Last),
2093 " ", Switch (Param .. Switch'Last), Index);
2094 Found_In_Config := True;
2095 return False;
2096
2097 when Parameter_No_Space
2098 | Parameter_Optional
2099 =>
2100 Callback (Switch (Switch'First .. Last),
2101 "", Switch (Param .. Switch'Last), Index);
2102 Found_In_Config := True;
2103 return False;
2104 end case;
2105 end if;
2106 return True;
2107 end Starts_With;
2108
2109 procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config);
2110 procedure Foreach_Starts_With is new Foreach_Switch (Starts_With);
2111
2112 -- Start of processing for For_Each_Simple_Switch
2113
2114 begin
2115 -- First determine if the switch corresponds to one belonging to the
2116 -- configuration. If so, run callback and exit.
2117
2118 -- ??? Is this necessary. On simple tests, we seem to have the same
2119 -- results with or without this call.
2120
2121 Foreach_In_Config (Config, Section);
2122
2123 if Found_In_Config then
2124 return;
2125 end if;
2126
2127 -- If adding a switch that can in fact be expanded through aliases,
2128 -- add separately each of its expansions.
2129
2130 -- This takes care of expansions like "-T" -> "-gnatwrs", where the
2131 -- alias and its expansion do not have the same prefix. Given the order
2132 -- in which we do things here, the expansion of the alias will itself
2133 -- be checked for a common prefix and split into simple switches.
2134
2135 if Unalias
2136 and then Config /= null
2137 and then Config.Aliases /= null
2138 then
2139 for A in Config.Aliases'Range loop
2140 if Config.Aliases (A).Section.all = Section
2141 and then Config.Aliases (A).Alias.all = Switch
2142 and then Parameter = ""
2143 then
2144 For_Each_Simple_Switch
2145 (Config, Section, Config.Aliases (A).Expansion.all, "");
2146 return;
2147 end if;
2148 end loop;
2149 end if;
2150
2151 -- If adding a switch grouping several switches, add each of the simple
2152 -- switches instead.
2153
2154 if Config /= null and then Config.Prefixes /= null then
2155 for P in Config.Prefixes'Range loop
2156 if Switch'Length > Config.Prefixes (P)'Length + 1
2157 and then
2158 Looking_At (Switch, Switch'First, Config.Prefixes (P).all)
2159 then
2160 -- Alias expansion will be done recursively
2161
2162 if Config.Switches = null then
2163 for S in Switch'First + Config.Prefixes (P)'Length
2164 .. Switch'Last
2165 loop
2166 For_Each_Simple_Switch
2167 (Config, Section,
2168 Config.Prefixes (P).all & Switch (S), "");
2169 end loop;
2170
2171 return;
2172
2173 elsif Group_Analysis
2174 (Config.Prefixes (P).all,
2175 Switch
2176 (Switch'First + Config.Prefixes (P)'Length .. Switch'Last))
2177 then
2178 -- Recursive calls already done on each switch of the group:
2179 -- Return without executing Callback.
2180
2181 return;
2182 end if;
2183 end if;
2184 end loop;
2185 end if;
2186
2187 -- Test if added switch is a known switch with parameter attached
2188 -- instead of being specified separately
2189
2190 if Parameter = ""
2191 and then Config /= null
2192 and then Config.Switches /= null
2193 then
2194 Found_In_Config := False;
2195 Foreach_Starts_With (Config, Section);
2196
2197 if Found_In_Config then
2198 return;
2199 end if;
2200 end if;
2201
2202 -- The switch is invalid in the config, but we still want to report it.
2203 -- The config could, for instance, include "*" to specify it accepts
2204 -- all switches.
2205
2206 Callback (Switch, " ", Parameter, Index => -1);
2207 end For_Each_Simple_Switch;
2208
2209 ----------------
2210 -- Add_Switch --
2211 ----------------
2212
2213 procedure Add_Switch
2214 (Cmd : in out Command_Line;
2215 Switch : String;
2216 Parameter : String := "";
2217 Separator : Character := ASCII.NUL;
2218 Section : String := "";
2219 Add_Before : Boolean := False)
2220 is
2221 Success : Boolean;
2222 pragma Unreferenced (Success);
2223 begin
2224 Add_Switch (Cmd, Switch, Parameter, Separator,
2225 Section, Add_Before, Success);
2226 end Add_Switch;
2227
2228 ----------------
2229 -- Add_Switch --
2230 ----------------
2231
2232 procedure Add_Switch
2233 (Cmd : in out Command_Line;
2234 Switch : String;
2235 Parameter : String := "";
2236 Separator : Character := ASCII.NUL;
2237 Section : String := "";
2238 Add_Before : Boolean := False;
2239 Success : out Boolean)
2240 is
2241 procedure Add_Simple_Switch
2242 (Simple : String;
2243 Sepa : String;
2244 Param : String;
2245 Index : Integer);
2246 -- Add a new switch that has had all its aliases expanded, and switches
2247 -- ungrouped. We know there are no more aliases in Switches.
2248
2249 -----------------------
2250 -- Add_Simple_Switch --
2251 -----------------------
2252
2253 procedure Add_Simple_Switch
2254 (Simple : String;
2255 Sepa : String;
2256 Param : String;
2257 Index : Integer)
2258 is
2259 Sep : Character;
2260
2261 begin
2262 if Index = -1
2263 and then Cmd.Config /= null
2264 and then not Cmd.Config.Star_Switch
2265 then
2266 raise Invalid_Switch
2267 with "Invalid switch " & Simple;
2268 end if;
2269
2270 if Separator /= ASCII.NUL then
2271 Sep := Separator;
2272
2273 elsif Sepa = "" then
2274 Sep := ASCII.NUL;
2275 else
2276 Sep := Sepa (Sepa'First);
2277 end if;
2278
2279 if Cmd.Expanded = null then
2280 Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple));
2281
2282 if Param /= "" then
2283 Cmd.Params :=
2284 new Argument_List'(1 .. 1 => new String'(Sep & Param));
2285 else
2286 Cmd.Params := new Argument_List'(1 .. 1 => null);
2287 end if;
2288
2289 if Section = "" then
2290 Cmd.Sections := new Argument_List'(1 .. 1 => null);
2291 else
2292 Cmd.Sections :=
2293 new Argument_List'(1 .. 1 => new String'(Section));
2294 end if;
2295
2296 else
2297 -- Do we already have this switch?
2298
2299 for C in Cmd.Expanded'Range loop
2300 if Cmd.Expanded (C).all = Simple
2301 and then
2302 ((Cmd.Params (C) = null and then Param = "")
2303 or else
2304 (Cmd.Params (C) /= null
2305 and then Cmd.Params (C).all = Sep & Param))
2306 and then
2307 ((Cmd.Sections (C) = null and then Section = "")
2308 or else
2309 (Cmd.Sections (C) /= null
2310 and then Cmd.Sections (C).all = Section))
2311 then
2312 return;
2313 end if;
2314 end loop;
2315
2316 -- Inserting at least one switch
2317
2318 Success := True;
2319 Add (Cmd.Expanded, new String'(Simple), Add_Before);
2320
2321 if Param /= "" then
2322 Add
2323 (Cmd.Params,
2324 new String'(Sep & Param),
2325 Add_Before);
2326 else
2327 Add
2328 (Cmd.Params,
2329 null,
2330 Add_Before);
2331 end if;
2332
2333 if Section = "" then
2334 Add
2335 (Cmd.Sections,
2336 null,
2337 Add_Before);
2338 else
2339 Add
2340 (Cmd.Sections,
2341 new String'(Section),
2342 Add_Before);
2343 end if;
2344 end if;
2345 end Add_Simple_Switch;
2346
2347 procedure Add_Simple_Switches is
2348 new For_Each_Simple_Switch (Add_Simple_Switch);
2349
2350 -- Local Variables
2351
2352 Section_Valid : Boolean := False;
2353
2354 -- Start of processing for Add_Switch
2355
2356 begin
2357 if Section /= "" and then Cmd.Config /= null then
2358 for S in Cmd.Config.Sections'Range loop
2359 if Section = Cmd.Config.Sections (S).all then
2360 Section_Valid := True;
2361 exit;
2362 end if;
2363 end loop;
2364
2365 if not Section_Valid then
2366 raise Invalid_Section;
2367 end if;
2368 end if;
2369
2370 Success := False;
2371 Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
2372 Free (Cmd.Coalesce);
2373 end Add_Switch;
2374
2375 ------------
2376 -- Remove --
2377 ------------
2378
2379 procedure Remove (Line : in out Argument_List_Access; Index : Integer) is
2380 Tmp : Argument_List_Access := Line;
2381
2382 begin
2383 Line := new Argument_List (Tmp'First .. Tmp'Last - 1);
2384
2385 if Index /= Tmp'First then
2386 Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1);
2387 end if;
2388
2389 Free (Tmp (Index));
2390
2391 if Index /= Tmp'Last then
2392 Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last);
2393 end if;
2394
2395 Unchecked_Free (Tmp);
2396 end Remove;
2397
2398 ---------
2399 -- Add --
2400 ---------
2401
2402 procedure Add
2403 (Line : in out Argument_List_Access;
2404 Str : String_Access;
2405 Before : Boolean := False)
2406 is
2407 Tmp : Argument_List_Access := Line;
2408
2409 begin
2410 if Tmp /= null then
2411 Line := new Argument_List (Tmp'First .. Tmp'Last + 1);
2412
2413 if Before then
2414 Line (Tmp'First) := Str;
2415 Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all;
2416 else
2417 Line (Tmp'Range) := Tmp.all;
2418 Line (Tmp'Last + 1) := Str;
2419 end if;
2420
2421 Unchecked_Free (Tmp);
2422
2423 else
2424 Line := new Argument_List'(1 .. 1 => Str);
2425 end if;
2426 end Add;
2427
2428 -------------------
2429 -- Remove_Switch --
2430 -------------------
2431
2432 procedure Remove_Switch
2433 (Cmd : in out Command_Line;
2434 Switch : String;
2435 Remove_All : Boolean := False;
2436 Has_Parameter : Boolean := False;
2437 Section : String := "")
2438 is
2439 Success : Boolean;
2440 pragma Unreferenced (Success);
2441 begin
2442 Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success);
2443 end Remove_Switch;
2444
2445 -------------------
2446 -- Remove_Switch --
2447 -------------------
2448
2449 procedure Remove_Switch
2450 (Cmd : in out Command_Line;
2451 Switch : String;
2452 Remove_All : Boolean := False;
2453 Has_Parameter : Boolean := False;
2454 Section : String := "";
2455 Success : out Boolean)
2456 is
2457 procedure Remove_Simple_Switch
2458 (Simple, Separator, Param : String; Index : Integer);
2459 -- Removes a simple switch, with no aliasing or grouping
2460
2461 --------------------------
2462 -- Remove_Simple_Switch --
2463 --------------------------
2464
2465 procedure Remove_Simple_Switch
2466 (Simple, Separator, Param : String; Index : Integer)
2467 is
2468 C : Integer;
2469 pragma Unreferenced (Param, Separator, Index);
2470
2471 begin
2472 if Cmd.Expanded /= null then
2473 C := Cmd.Expanded'First;
2474 while C <= Cmd.Expanded'Last loop
2475 if Cmd.Expanded (C).all = Simple
2476 and then
2477 (Remove_All
2478 or else (Cmd.Sections (C) = null
2479 and then Section = "")
2480 or else (Cmd.Sections (C) /= null
2481 and then Section = Cmd.Sections (C).all))
2482 and then (not Has_Parameter or else Cmd.Params (C) /= null)
2483 then
2484 Remove (Cmd.Expanded, C);
2485 Remove (Cmd.Params, C);
2486 Remove (Cmd.Sections, C);
2487 Success := True;
2488
2489 if not Remove_All then
2490 return;
2491 end if;
2492
2493 else
2494 C := C + 1;
2495 end if;
2496 end loop;
2497 end if;
2498 end Remove_Simple_Switch;
2499
2500 procedure Remove_Simple_Switches is
2501 new For_Each_Simple_Switch (Remove_Simple_Switch);
2502
2503 -- Start of processing for Remove_Switch
2504
2505 begin
2506 Success := False;
2507 Remove_Simple_Switches
2508 (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter);
2509 Free (Cmd.Coalesce);
2510 end Remove_Switch;
2511
2512 -------------------
2513 -- Remove_Switch --
2514 -------------------
2515
2516 procedure Remove_Switch
2517 (Cmd : in out Command_Line;
2518 Switch : String;
2519 Parameter : String;
2520 Section : String := "")
2521 is
2522 procedure Remove_Simple_Switch
2523 (Simple, Separator, Param : String; Index : Integer);
2524 -- Removes a simple switch, with no aliasing or grouping
2525
2526 --------------------------
2527 -- Remove_Simple_Switch --
2528 --------------------------
2529
2530 procedure Remove_Simple_Switch
2531 (Simple, Separator, Param : String; Index : Integer)
2532 is
2533 pragma Unreferenced (Separator, Index);
2534 C : Integer;
2535
2536 begin
2537 if Cmd.Expanded /= null then
2538 C := Cmd.Expanded'First;
2539 while C <= Cmd.Expanded'Last loop
2540 if Cmd.Expanded (C).all = Simple
2541 and then
2542 ((Cmd.Sections (C) = null
2543 and then Section = "")
2544 or else
2545 (Cmd.Sections (C) /= null
2546 and then Section = Cmd.Sections (C).all))
2547 and then
2548 ((Cmd.Params (C) = null and then Param = "")
2549 or else
2550 (Cmd.Params (C) /= null
2551
2552 -- Ignore the separator stored in Parameter
2553
2554 and then
2555 Cmd.Params (C) (Cmd.Params (C)'First + 1
2556 .. Cmd.Params (C)'Last) = Param))
2557 then
2558 Remove (Cmd.Expanded, C);
2559 Remove (Cmd.Params, C);
2560 Remove (Cmd.Sections, C);
2561
2562 -- The switch is necessarily unique by construction of
2563 -- Add_Switch.
2564
2565 return;
2566
2567 else
2568 C := C + 1;
2569 end if;
2570 end loop;
2571 end if;
2572 end Remove_Simple_Switch;
2573
2574 procedure Remove_Simple_Switches is
2575 new For_Each_Simple_Switch (Remove_Simple_Switch);
2576
2577 -- Start of processing for Remove_Switch
2578
2579 begin
2580 Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter);
2581 Free (Cmd.Coalesce);
2582 end Remove_Switch;
2583
2584 --------------------
2585 -- Group_Switches --
2586 --------------------
2587
2588 procedure Group_Switches
2589 (Cmd : Command_Line;
2590 Result : Argument_List_Access;
2591 Sections : Argument_List_Access;
2592 Params : Argument_List_Access)
2593 is
2594 function Compatible_Parameter (Param : String_Access) return Boolean;
2595 -- True when the parameter can be part of a group
2596
2597 --------------------------
2598 -- Compatible_Parameter --
2599 --------------------------
2600
2601 function Compatible_Parameter (Param : String_Access) return Boolean is
2602 begin
2603 -- No parameter OK
2604
2605 if Param = null then
2606 return True;
2607
2608 -- We need parameters without separators
2609
2610 elsif Param (Param'First) /= ASCII.NUL then
2611 return False;
2612
2613 -- Parameters must be all digits
2614
2615 else
2616 for J in Param'First + 1 .. Param'Last loop
2617 if Param (J) not in '0' .. '9' then
2618 return False;
2619 end if;
2620 end loop;
2621
2622 return True;
2623 end if;
2624 end Compatible_Parameter;
2625
2626 -- Local declarations
2627
2628 Group : Ada.Strings.Unbounded.Unbounded_String;
2629 First : Natural;
2630 use type Ada.Strings.Unbounded.Unbounded_String;
2631
2632 -- Start of processing for Group_Switches
2633
2634 begin
2635 if Cmd.Config = null or else Cmd.Config.Prefixes = null then
2636 return;
2637 end if;
2638
2639 for P in Cmd.Config.Prefixes'Range loop
2640 Group := Ada.Strings.Unbounded.Null_Unbounded_String;
2641 First := 0;
2642
2643 for C in Result'Range loop
2644 if Result (C) /= null
2645 and then Compatible_Parameter (Params (C))
2646 and then Looking_At
2647 (Result (C).all,
2648 Result (C)'First,
2649 Cmd.Config.Prefixes (P).all)
2650 then
2651 -- If we are still in the same section, group the switches
2652
2653 if First = 0
2654 or else
2655 (Sections (C) = null
2656 and then Sections (First) = null)
2657 or else
2658 (Sections (C) /= null
2659 and then Sections (First) /= null
2660 and then Sections (C).all = Sections (First).all)
2661 then
2662 Group :=
2663 Group &
2664 Result (C)
2665 (Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
2666 Result (C)'Last);
2667
2668 if Params (C) /= null then
2669 Group :=
2670 Group &
2671 Params (C) (Params (C)'First + 1 .. Params (C)'Last);
2672 Free (Params (C));
2673 end if;
2674
2675 if First = 0 then
2676 First := C;
2677 end if;
2678
2679 Free (Result (C));
2680
2681 -- We changed section: we put the grouped switches to the first
2682 -- place, on continue with the new section.
2683
2684 else
2685 Result (First) :=
2686 new String'
2687 (Cmd.Config.Prefixes (P).all &
2688 Ada.Strings.Unbounded.To_String (Group));
2689 Group :=
2690 Ada.Strings.Unbounded.To_Unbounded_String
2691 (Result (C)
2692 (Result (C)'First + Cmd.Config.Prefixes (P)'Length ..
2693 Result (C)'Last));
2694 First := C;
2695 end if;
2696 end if;
2697 end loop;
2698
2699 if First > 0 then
2700 Result (First) :=
2701 new String'
2702 (Cmd.Config.Prefixes (P).all &
2703 Ada.Strings.Unbounded.To_String (Group));
2704 end if;
2705 end loop;
2706 end Group_Switches;
2707
2708 --------------------
2709 -- Alias_Switches --
2710 --------------------
2711
2712 procedure Alias_Switches
2713 (Cmd : Command_Line;
2714 Result : Argument_List_Access;
2715 Params : Argument_List_Access)
2716 is
2717 Found : Boolean;
2718 First : Natural;
2719
2720 procedure Check_Cb (Switch, Separator, Param : String; Index : Integer);
2721 -- Checks whether the command line contains [Switch]. Sets the global
2722 -- variable [Found] appropriately. This is called for each simple switch
2723 -- that make up an alias, to know whether the alias should be applied.
2724
2725 procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer);
2726 -- Remove the simple switch [Switch] from the command line, since it is
2727 -- part of a simpler alias
2728
2729 --------------
2730 -- Check_Cb --
2731 --------------
2732
2733 procedure Check_Cb
2734 (Switch, Separator, Param : String; Index : Integer)
2735 is
2736 pragma Unreferenced (Separator, Index);
2737
2738 begin
2739 if Found then
2740 for E in Result'Range loop
2741 if Result (E) /= null
2742 and then
2743 (Params (E) = null
2744 or else Params (E) (Params (E)'First + 1 ..
2745 Params (E)'Last) = Param)
2746 and then Result (E).all = Switch
2747 then
2748 return;
2749 end if;
2750 end loop;
2751
2752 Found := False;
2753 end if;
2754 end Check_Cb;
2755
2756 ---------------
2757 -- Remove_Cb --
2758 ---------------
2759
2760 procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer)
2761 is
2762 pragma Unreferenced (Separator, Index);
2763
2764 begin
2765 for E in Result'Range loop
2766 if Result (E) /= null
2767 and then
2768 (Params (E) = null
2769 or else Params (E) (Params (E)'First + 1
2770 .. Params (E)'Last) = Param)
2771 and then Result (E).all = Switch
2772 then
2773 if First > E then
2774 First := E;
2775 end if;
2776
2777 Free (Result (E));
2778 Free (Params (E));
2779 return;
2780 end if;
2781 end loop;
2782 end Remove_Cb;
2783
2784 procedure Check_All is new For_Each_Simple_Switch (Check_Cb);
2785 procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb);
2786
2787 -- Start of processing for Alias_Switches
2788
2789 begin
2790 if Cmd.Config = null or else Cmd.Config.Aliases = null then
2791 return;
2792 end if;
2793
2794 for A in Cmd.Config.Aliases'Range loop
2795
2796 -- Compute the various simple switches that make up the alias. We
2797 -- split the expansion into as many simple switches as possible, and
2798 -- then check whether the expanded command line has all of them.
2799
2800 Found := True;
2801 Check_All (Cmd.Config,
2802 Switch => Cmd.Config.Aliases (A).Expansion.all,
2803 Section => Cmd.Config.Aliases (A).Section.all);
2804
2805 if Found then
2806 First := Integer'Last;
2807 Remove_All (Cmd.Config,
2808 Switch => Cmd.Config.Aliases (A).Expansion.all,
2809 Section => Cmd.Config.Aliases (A).Section.all);
2810 Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all);
2811 end if;
2812 end loop;
2813 end Alias_Switches;
2814
2815 -------------------
2816 -- Sort_Sections --
2817 -------------------
2818
2819 procedure Sort_Sections
2820 (Line : not null GNAT.OS_Lib.Argument_List_Access;
2821 Sections : GNAT.OS_Lib.Argument_List_Access;
2822 Params : GNAT.OS_Lib.Argument_List_Access)
2823 is
2824 Sections_List : Argument_List_Access :=
2825 new Argument_List'(1 .. 1 => null);
2826 Found : Boolean;
2827 Old_Line : constant Argument_List := Line.all;
2828 Old_Sections : constant Argument_List := Sections.all;
2829 Old_Params : constant Argument_List := Params.all;
2830 Index : Natural;
2831
2832 begin
2833 -- First construct a list of all sections
2834
2835 for E in Line'Range loop
2836 if Sections (E) /= null then
2837 Found := False;
2838 for S in Sections_List'Range loop
2839 if (Sections_List (S) = null and then Sections (E) = null)
2840 or else
2841 (Sections_List (S) /= null
2842 and then Sections (E) /= null
2843 and then Sections_List (S).all = Sections (E).all)
2844 then
2845 Found := True;
2846 exit;
2847 end if;
2848 end loop;
2849
2850 if not Found then
2851 Add (Sections_List, Sections (E));
2852 end if;
2853 end if;
2854 end loop;
2855
2856 Index := Line'First;
2857
2858 for S in Sections_List'Range loop
2859 for E in Old_Line'Range loop
2860 if (Sections_List (S) = null and then Old_Sections (E) = null)
2861 or else
2862 (Sections_List (S) /= null
2863 and then Old_Sections (E) /= null
2864 and then Sections_List (S).all = Old_Sections (E).all)
2865 then
2866 Line (Index) := Old_Line (E);
2867 Sections (Index) := Old_Sections (E);
2868 Params (Index) := Old_Params (E);
2869 Index := Index + 1;
2870 end if;
2871 end loop;
2872 end loop;
2873
2874 Unchecked_Free (Sections_List);
2875 end Sort_Sections;
2876
2877 -----------
2878 -- Start --
2879 -----------
2880
2881 procedure Start
2882 (Cmd : in out Command_Line;
2883 Iter : in out Command_Line_Iterator;
2884 Expanded : Boolean := False)
2885 is
2886 begin
2887 if Cmd.Expanded = null then
2888 Iter.List := null;
2889 return;
2890 end if;
2891
2892 -- Reorder the expanded line so that sections are grouped
2893
2894 Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params);
2895
2896 -- Coalesce the switches as much as possible
2897
2898 if not Expanded
2899 and then Cmd.Coalesce = null
2900 then
2901 Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range);
2902 for E in Cmd.Expanded'Range loop
2903 Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all);
2904 end loop;
2905
2906 Free (Cmd.Coalesce_Sections);
2907 Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range);
2908 for E in Cmd.Sections'Range loop
2909 Cmd.Coalesce_Sections (E) :=
2910 (if Cmd.Sections (E) = null then null
2911 else new String'(Cmd.Sections (E).all));
2912 end loop;
2913
2914 Free (Cmd.Coalesce_Params);
2915 Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range);
2916 for E in Cmd.Params'Range loop
2917 Cmd.Coalesce_Params (E) :=
2918 (if Cmd.Params (E) = null then null
2919 else new String'(Cmd.Params (E).all));
2920 end loop;
2921
2922 -- Not a clone, since we will not modify the parameters anyway
2923
2924 Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params);
2925 Group_Switches
2926 (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params);
2927 end if;
2928
2929 if Expanded then
2930 Iter.List := Cmd.Expanded;
2931 Iter.Params := Cmd.Params;
2932 Iter.Sections := Cmd.Sections;
2933 else
2934 Iter.List := Cmd.Coalesce;
2935 Iter.Params := Cmd.Coalesce_Params;
2936 Iter.Sections := Cmd.Coalesce_Sections;
2937 end if;
2938
2939 if Iter.List = null then
2940 Iter.Current := Integer'Last;
2941 else
2942 Iter.Current := Iter.List'First - 1;
2943 Next (Iter);
2944 end if;
2945 end Start;
2946
2947 --------------------
2948 -- Current_Switch --
2949 --------------------
2950
2951 function Current_Switch (Iter : Command_Line_Iterator) return String is
2952 begin
2953 return Iter.List (Iter.Current).all;
2954 end Current_Switch;
2955
2956 --------------------
2957 -- Is_New_Section --
2958 --------------------
2959
2960 function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is
2961 Section : constant String := Current_Section (Iter);
2962
2963 begin
2964 if Iter.Sections = null then
2965 return False;
2966
2967 elsif Iter.Current = Iter.Sections'First
2968 or else Iter.Sections (Iter.Current - 1) = null
2969 then
2970 return Section /= "";
2971
2972 else
2973 return Section /= Iter.Sections (Iter.Current - 1).all;
2974 end if;
2975 end Is_New_Section;
2976
2977 ---------------------
2978 -- Current_Section --
2979 ---------------------
2980
2981 function Current_Section (Iter : Command_Line_Iterator) return String is
2982 begin
2983 if Iter.Sections = null
2984 or else Iter.Current > Iter.Sections'Last
2985 or else Iter.Sections (Iter.Current) = null
2986 then
2987 return "";
2988 end if;
2989
2990 return Iter.Sections (Iter.Current).all;
2991 end Current_Section;
2992
2993 -----------------------
2994 -- Current_Separator --
2995 -----------------------
2996
2997 function Current_Separator (Iter : Command_Line_Iterator) return String is
2998 begin
2999 if Iter.Params = null
3000 or else Iter.Current > Iter.Params'Last
3001 or else Iter.Params (Iter.Current) = null
3002 then
3003 return "";
3004
3005 else
3006 declare
3007 Sep : constant Character :=
3008 Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First);
3009 begin
3010 if Sep = ASCII.NUL then
3011 return "";
3012 else
3013 return "" & Sep;
3014 end if;
3015 end;
3016 end if;
3017 end Current_Separator;
3018
3019 -----------------------
3020 -- Current_Parameter --
3021 -----------------------
3022
3023 function Current_Parameter (Iter : Command_Line_Iterator) return String is
3024 begin
3025 if Iter.Params = null
3026 or else Iter.Current > Iter.Params'Last
3027 or else Iter.Params (Iter.Current) = null
3028 then
3029 return "";
3030
3031 else
3032 -- Return result, skipping separator
3033
3034 declare
3035 P : constant String := Iter.Params (Iter.Current).all;
3036 begin
3037 return P (P'First + 1 .. P'Last);
3038 end;
3039 end if;
3040 end Current_Parameter;
3041
3042 --------------
3043 -- Has_More --
3044 --------------
3045
3046 function Has_More (Iter : Command_Line_Iterator) return Boolean is
3047 begin
3048 return Iter.List /= null and then Iter.Current <= Iter.List'Last;
3049 end Has_More;
3050
3051 ----------
3052 -- Next --
3053 ----------
3054
3055 procedure Next (Iter : in out Command_Line_Iterator) is
3056 begin
3057 Iter.Current := Iter.Current + 1;
3058 while Iter.Current <= Iter.List'Last
3059 and then Iter.List (Iter.Current) = null
3060 loop
3061 Iter.Current := Iter.Current + 1;
3062 end loop;
3063 end Next;
3064
3065 ----------
3066 -- Free --
3067 ----------
3068
3069 procedure Free (Config : in out Command_Line_Configuration) is
3070 procedure Unchecked_Free is new
3071 Ada.Unchecked_Deallocation
3072 (Switch_Definitions, Switch_Definitions_List);
3073
3074 procedure Unchecked_Free is new
3075 Ada.Unchecked_Deallocation
3076 (Alias_Definitions, Alias_Definitions_List);
3077
3078 begin
3079 if Config /= null then
3080 Free (Config.Prefixes);
3081 Free (Config.Sections);
3082 Free (Config.Usage);
3083 Free (Config.Help);
3084 Free (Config.Help_Msg);
3085
3086 if Config.Aliases /= null then
3087 for A in Config.Aliases'Range loop
3088 Free (Config.Aliases (A).Alias);
3089 Free (Config.Aliases (A).Expansion);
3090 Free (Config.Aliases (A).Section);
3091 end loop;
3092
3093 Unchecked_Free (Config.Aliases);
3094 end if;
3095
3096 if Config.Switches /= null then
3097 for S in Config.Switches'Range loop
3098 Free (Config.Switches (S).Switch);
3099 Free (Config.Switches (S).Long_Switch);
3100 Free (Config.Switches (S).Help);
3101 Free (Config.Switches (S).Section);
3102 Free (Config.Switches (S).Argument);
3103 end loop;
3104
3105 Unchecked_Free (Config.Switches);
3106 end if;
3107
3108 Unchecked_Free (Config);
3109 end if;
3110 end Free;
3111
3112 ----------
3113 -- Free --
3114 ----------
3115
3116 procedure Free (Cmd : in out Command_Line) is
3117 begin
3118 Free (Cmd.Expanded);
3119 Free (Cmd.Coalesce);
3120 Free (Cmd.Coalesce_Sections);
3121 Free (Cmd.Coalesce_Params);
3122 Free (Cmd.Params);
3123 Free (Cmd.Sections);
3124 end Free;
3125
3126 ---------------
3127 -- Set_Usage --
3128 ---------------
3129
3130 procedure Set_Usage
3131 (Config : in out Command_Line_Configuration;
3132 Usage : String := "[switches] [arguments]";
3133 Help : String := "";
3134 Help_Msg : String := "")
3135 is
3136 begin
3137 if Config = null then
3138 Config := new Command_Line_Configuration_Record;
3139 end if;
3140
3141 Free (Config.Usage);
3142 Free (Config.Help);
3143 Free (Config.Help_Msg);
3144
3145 Config.Usage := new String'(Usage);
3146 Config.Help := new String'(Help);
3147 Config.Help_Msg := new String'(Help_Msg);
3148 end Set_Usage;
3149
3150 ------------------
3151 -- Display_Help --
3152 ------------------
3153
3154 procedure Display_Help (Config : Command_Line_Configuration) is
3155 function Switch_Name
3156 (Def : Switch_Definition;
3157 Section : String) return String;
3158 -- Return the "-short, --long=ARG" string for Def.
3159 -- Returns "" if the switch is not in the section.
3160
3161 function Param_Name
3162 (P : Switch_Parameter_Type;
3163 Name : String := "ARG") return String;
3164 -- Return the display for a switch parameter
3165
3166 procedure Display_Section_Help (Section : String);
3167 -- Display the help for a specific section ("" is the default section)
3168
3169 --------------------------
3170 -- Display_Section_Help --
3171 --------------------------
3172
3173 procedure Display_Section_Help (Section : String) is
3174 Max_Len : Natural := 0;
3175
3176 begin
3177 -- ??? Special display for "*"
3178
3179 New_Line;
3180
3181 if Section /= "" then
3182 Put_Line ("Switches after " & Section);
3183 end if;
3184
3185 -- Compute size of the switches column
3186
3187 for S in Config.Switches'Range loop
3188 Max_Len := Natural'Max
3189 (Max_Len, Switch_Name (Config.Switches (S), Section)'Length);
3190 end loop;
3191
3192 if Config.Aliases /= null then
3193 for A in Config.Aliases'Range loop
3194 if Config.Aliases (A).Section.all = Section then
3195 Max_Len := Natural'Max
3196 (Max_Len, Config.Aliases (A).Alias'Length);
3197 end if;
3198 end loop;
3199 end if;
3200
3201 -- Display the switches
3202
3203 for S in Config.Switches'Range loop
3204 declare
3205 N : constant String :=
3206 Switch_Name (Config.Switches (S), Section);
3207
3208 begin
3209 if N /= "" then
3210 Put (" ");
3211 Put (N);
3212 Put ((1 .. Max_Len - N'Length + 1 => ' '));
3213
3214 if Config.Switches (S).Help /= null then
3215 Put (Config.Switches (S).Help.all);
3216 end if;
3217
3218 New_Line;
3219 end if;
3220 end;
3221 end loop;
3222
3223 -- Display the aliases
3224
3225 if Config.Aliases /= null then
3226 for A in Config.Aliases'Range loop
3227 if Config.Aliases (A).Section.all = Section then
3228 Put (" ");
3229 Put (Config.Aliases (A).Alias.all);
3230 Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1
3231 => ' '));
3232 Put ("Equivalent to " & Config.Aliases (A).Expansion.all);
3233 New_Line;
3234 end if;
3235 end loop;
3236 end if;
3237 end Display_Section_Help;
3238
3239 ----------------
3240 -- Param_Name --
3241 ----------------
3242
3243 function Param_Name
3244 (P : Switch_Parameter_Type;
3245 Name : String := "ARG") return String
3246 is
3247 begin
3248 case P is
3249 when Parameter_None =>
3250 return "";
3251
3252 when Parameter_With_Optional_Space =>
3253 return " " & To_Upper (Name);
3254
3255 when Parameter_With_Space_Or_Equal =>
3256 return "=" & To_Upper (Name);
3257
3258 when Parameter_No_Space =>
3259 return To_Upper (Name);
3260
3261 when Parameter_Optional =>
3262 return '[' & To_Upper (Name) & ']';
3263 end case;
3264 end Param_Name;
3265
3266 -----------------
3267 -- Switch_Name --
3268 -----------------
3269
3270 function Switch_Name
3271 (Def : Switch_Definition;
3272 Section : String) return String
3273 is
3274 use Ada.Strings.Unbounded;
3275 Result : Unbounded_String;
3276 P1, P2 : Switch_Parameter_Type;
3277 Last1, Last2 : Integer := 0;
3278
3279 begin
3280 if (Section = "" and then Def.Section = null)
3281 or else (Def.Section /= null and then Def.Section.all = Section)
3282 then
3283 if Def.Switch /= null and then Def.Switch.all = "*" then
3284 return "[any switch]";
3285 end if;
3286
3287 if Def.Switch /= null then
3288 Decompose_Switch (Def.Switch.all, P1, Last1);
3289 Append (Result, Def.Switch (Def.Switch'First .. Last1));
3290
3291 if Def.Long_Switch /= null then
3292 Decompose_Switch (Def.Long_Switch.all, P2, Last2);
3293 Append (Result, ", "
3294 & Def.Long_Switch (Def.Long_Switch'First .. Last2));
3295
3296 if Def.Argument = null then
3297 Append (Result, Param_Name (P2, "ARG"));
3298 else
3299 Append (Result, Param_Name (P2, Def.Argument.all));
3300 end if;
3301
3302 else
3303 if Def.Argument = null then
3304 Append (Result, Param_Name (P1, "ARG"));
3305 else
3306 Append (Result, Param_Name (P1, Def.Argument.all));
3307 end if;
3308 end if;
3309
3310 -- Def.Switch is null (Long_Switch must be non-null)
3311
3312 else
3313 Decompose_Switch (Def.Long_Switch.all, P2, Last2);
3314 Append (Result,
3315 Def.Long_Switch (Def.Long_Switch'First .. Last2));
3316
3317 if Def.Argument = null then
3318 Append (Result, Param_Name (P2, "ARG"));
3319 else
3320 Append (Result, Param_Name (P2, Def.Argument.all));
3321 end if;
3322 end if;
3323 end if;
3324
3325 return To_String (Result);
3326 end Switch_Name;
3327
3328 -- Start of processing for Display_Help
3329
3330 begin
3331 if Config = null then
3332 return;
3333 end if;
3334
3335 if Config.Help /= null and then Config.Help.all /= "" then
3336 Put_Line (Config.Help.all);
3337 end if;
3338
3339 if Config.Usage /= null then
3340 Put_Line ("Usage: "
3341 & Base_Name
3342 (Ada.Command_Line.Command_Name) & " " & Config.Usage.all);
3343 else
3344 Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name)
3345 & " [switches] [arguments]");
3346 end if;
3347
3348 if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then
3349 Put_Line (Config.Help_Msg.all);
3350
3351 else
3352 Display_Section_Help ("");
3353
3354 if Config.Sections /= null and then Config.Switches /= null then
3355 for S in Config.Sections'Range loop
3356 Display_Section_Help (Config.Sections (S).all);
3357 end loop;
3358 end if;
3359 end if;
3360 end Display_Help;
3361
3362 ------------
3363 -- Getopt --
3364 ------------
3365
3366 procedure Getopt
3367 (Config : Command_Line_Configuration;
3368 Callback : Switch_Handler := null;
3369 Parser : Opt_Parser := Command_Line_Parser;
3370 Concatenate : Boolean := True;
3371 Quiet : Boolean := False)
3372 is
3373 Local_Config : Command_Line_Configuration := Config;
3374 Getopt_Switches : String_Access;
3375 C : Character := ASCII.NUL;
3376
3377 Empty_Name : aliased constant String := "";
3378 Current_Section : Integer := -1;
3379 Section_Name : not null access constant String := Empty_Name'Access;
3380
3381 procedure Simple_Callback
3382 (Simple_Switch : String;
3383 Separator : String;
3384 Parameter : String;
3385 Index : Integer);
3386 -- Needs comments ???
3387
3388 procedure Do_Callback (Switch, Parameter : String; Index : Integer);
3389
3390 -----------------
3391 -- Do_Callback --
3392 -----------------
3393
3394 procedure Do_Callback (Switch, Parameter : String; Index : Integer) is
3395 begin
3396 -- Do automatic handling when possible
3397
3398 if Index /= -1 then
3399 case Local_Config.Switches (Index).Typ is
3400 when Switch_Untyped =>
3401 null; -- no automatic handling
3402
3403 when Switch_Boolean =>
3404 Local_Config.Switches (Index).Boolean_Output.all :=
3405 Local_Config.Switches (Index).Boolean_Value;
3406 return;
3407
3408 when Switch_Integer =>
3409 begin
3410 if Parameter = "" then
3411 Local_Config.Switches (Index).Integer_Output.all :=
3412 Local_Config.Switches (Index).Integer_Default;
3413 else
3414 Local_Config.Switches (Index).Integer_Output.all :=
3415 Integer'Value (Parameter);
3416 end if;
3417
3418 exception
3419 when Constraint_Error =>
3420 raise Invalid_Parameter
3421 with "Expected integer parameter for '"
3422 & Switch & "'";
3423 end;
3424
3425 return;
3426
3427 when Switch_String =>
3428 Free (Local_Config.Switches (Index).String_Output.all);
3429 Local_Config.Switches (Index).String_Output.all :=
3430 new String'(Parameter);
3431 return;
3432
3433 when Switch_Callback =>
3434 Local_Config.Switches (Index).Callback (Switch, Parameter);
3435 return;
3436 end case;
3437 end if;
3438
3439 -- Otherwise calls the user callback if one was defined
3440
3441 if Callback /= null then
3442 Callback (Switch => Switch,
3443 Parameter => Parameter,
3444 Section => Section_Name.all);
3445 end if;
3446 end Do_Callback;
3447
3448 procedure For_Each_Simple
3449 is new For_Each_Simple_Switch (Simple_Callback);
3450
3451 ---------------------
3452 -- Simple_Callback --
3453 ---------------------
3454
3455 procedure Simple_Callback
3456 (Simple_Switch : String;
3457 Separator : String;
3458 Parameter : String;
3459 Index : Integer)
3460 is
3461 pragma Unreferenced (Separator);
3462 begin
3463 Do_Callback (Switch => Simple_Switch,
3464 Parameter => Parameter,
3465 Index => Index);
3466 end Simple_Callback;
3467
3468 -- Start of processing for Getopt
3469
3470 begin
3471 -- We work with a local copy of Config, because Config can be null, for
3472 -- example if Define_Switch was never called. We could modify Config
3473 -- itself, but then we would have to make it into an 'in out' parameter,
3474 -- which would be incompatible.
3475
3476 if Local_Config = null then
3477 Local_Config := new Command_Line_Configuration_Record;
3478 end if;
3479
3480 if Local_Config.Switches = null then
3481 Local_Config.Switches := new Switch_Definitions (1 .. 0);
3482 end if;
3483
3484 -- Initialize sections
3485
3486 if Local_Config.Sections = null then
3487 Local_Config.Sections := new Argument_List'(1 .. 0 => null);
3488 end if;
3489
3490 Internal_Initialize_Option_Scan
3491 (Parser => Parser,
3492 Switch_Char => Parser.Switch_Character,
3493 Stop_At_First_Non_Switch => Parser.Stop_At_First,
3494 Section_Delimiters => Section_Delimiters (Local_Config));
3495
3496 Getopt_Switches := new String'
3497 (Get_Switches (Local_Config, Parser.Switch_Character, Section_Name.all)
3498 & " h -help");
3499
3500 -- Initialize output values for automatically handled switches
3501
3502 for S in Local_Config.Switches'Range loop
3503 case Local_Config.Switches (S).Typ is
3504 when Switch_Untyped | Switch_Callback =>
3505 null; -- Nothing to do
3506
3507 when Switch_Boolean =>
3508 Local_Config.Switches (S).Boolean_Output.all :=
3509 not Local_Config.Switches (S).Boolean_Value;
3510
3511 when Switch_Integer =>
3512 Local_Config.Switches (S).Integer_Output.all :=
3513 Local_Config.Switches (S).Integer_Initial;
3514
3515 when Switch_String =>
3516 if Local_Config.Switches (S).String_Output.all = null then
3517 Local_Config.Switches (S).String_Output.all :=
3518 new String'("");
3519 end if;
3520 end case;
3521 end loop;
3522
3523 -- For all sections, and all switches within those sections
3524
3525 loop
3526 C := Getopt (Switches => Getopt_Switches.all,
3527 Concatenate => Concatenate,
3528 Parser => Parser);
3529
3530 if C = '*' then
3531 -- Full_Switch already includes the leading '-'
3532
3533 Do_Callback (Switch => Full_Switch (Parser),
3534 Parameter => Parameter (Parser),
3535 Index => -1);
3536
3537 elsif C /= ASCII.NUL then
3538 if Full_Switch (Parser) = "h"
3539 or else
3540 Full_Switch (Parser) = "-help"
3541 then
3542 Display_Help (Local_Config);
3543 raise Exit_From_Command_Line;
3544 end if;
3545
3546 -- Do switch expansion if needed
3547
3548 For_Each_Simple
3549 (Local_Config,
3550 Section => Section_Name.all,
3551 Switch => Parser.Switch_Character & Full_Switch (Parser),
3552 Parameter => Parameter (Parser));
3553
3554 else
3555 if Current_Section = -1 then
3556 Current_Section := Local_Config.Sections'First;
3557 else
3558 Current_Section := Current_Section + 1;
3559 end if;
3560
3561 exit when Current_Section > Local_Config.Sections'Last;
3562
3563 Section_Name := Local_Config.Sections (Current_Section);
3564 Goto_Section (Section_Name.all, Parser);
3565
3566 Free (Getopt_Switches);
3567 Getopt_Switches := new String'
3568 (Get_Switches
3569 (Local_Config, Parser.Switch_Character, Section_Name.all));
3570 end if;
3571 end loop;
3572
3573 Free (Getopt_Switches);
3574
3575 exception
3576 when Invalid_Switch =>
3577 Free (Getopt_Switches);
3578
3579 -- Message inspired by "ls" on Unix
3580
3581 if not Quiet then
3582 Put_Line (Standard_Error,
3583 Base_Name (Ada.Command_Line.Command_Name)
3584 & ": unrecognized option '"
3585 & Full_Switch (Parser)
3586 & "'");
3587 Try_Help;
3588 end if;
3589
3590 raise;
3591
3592 when others =>
3593 Free (Getopt_Switches);
3594 raise;
3595 end Getopt;
3596
3597 -----------
3598 -- Build --
3599 -----------
3600
3601 procedure Build
3602 (Line : in out Command_Line;
3603 Args : out GNAT.OS_Lib.Argument_List_Access;
3604 Expanded : Boolean := False;
3605 Switch_Char : Character := '-')
3606 is
3607 Iter : Command_Line_Iterator;
3608 Count : Natural := 0;
3609
3610 begin
3611 Start (Line, Iter, Expanded => Expanded);
3612 while Has_More (Iter) loop
3613 if Is_New_Section (Iter) then
3614 Count := Count + 1;
3615 end if;
3616
3617 Count := Count + 1;
3618 Next (Iter);
3619 end loop;
3620
3621 Args := new Argument_List (1 .. Count);
3622 Count := Args'First;
3623
3624 Start (Line, Iter, Expanded => Expanded);
3625 while Has_More (Iter) loop
3626 if Is_New_Section (Iter) then
3627 Args (Count) := new String'(Switch_Char & Current_Section (Iter));
3628 Count := Count + 1;
3629 end if;
3630
3631 Args (Count) := new String'(Current_Switch (Iter)
3632 & Current_Separator (Iter)
3633 & Current_Parameter (Iter));
3634 Count := Count + 1;
3635 Next (Iter);
3636 end loop;
3637 end Build;
3638
3639 --------------
3640 -- Try_Help --
3641 --------------
3642
3643 -- Note: Any change to the message displayed should also be done in
3644 -- gnatbind.adb that does not use this interface.
3645
3646 procedure Try_Help is
3647 begin
3648 Put_Line
3649 (Standard_Error,
3650 "try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe")
3651 & " --help"" for more information.");
3652 end Try_Help;
3653
3654 end GNAT.Command_Line;
This page took 0.198686 seconds and 5 git commands to generate.