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