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