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