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