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