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