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