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-2012, 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 S := Getopt (Switches => "*", 1685 Concatenate => False, 1686 Parser => Parser); 1687 1688 else 1689 S := Getopt (Switches => "* " & Getopt_Description, 1690 Concatenate => False, 1691 Parser => Parser); 1692 end if; 1693 1694 exit when S = ASCII.NUL; 1695 1696 declare 1697 Sw : constant String := Real_Full_Switch (S, Parser); 1698 Is_Section : Boolean := False; 1699 1700 begin 1701 if Cmd.Config /= null 1702 and then Cmd.Config.Sections /= null 1703 then 1704 Section_Search : 1705 for S in Cmd.Config.Sections'Range loop 1706 if Sw = Cmd.Config.Sections (S).all then 1707 Section := Cmd.Config.Sections (S); 1708 Is_Section := True; 1709 1710 exit Section_Search; 1711 end if; 1712 end loop Section_Search; 1713 end if; 1714 1715 if not Is_Section then 1716 if Section = null then 1717 Add_Switch (Cmd, Sw, Parameter (Parser)); 1718 else 1719 Add_Switch 1720 (Cmd, Sw, Parameter (Parser), 1721 Section => Section.all); 1722 end if; 1723 end if; 1724 end; 1725 1726 exception 1727 when Invalid_Parameter => 1728 1729 -- Add it with no parameter, if that's the way the user 1730 -- wants it. 1731 1732 -- Specify the separator in all cases, as the switch might 1733 -- need to be unaliased, and the alias might contain 1734 -- switches with parameters. 1735 1736 if Section = null then 1737 Add_Switch 1738 (Cmd, Switch_Char & Full_Switch (Parser)); 1739 else 1740 Add_Switch 1741 (Cmd, Switch_Char & Full_Switch (Parser), 1742 Section => Section.all); 1743 end if; 1744 end; 1745 end loop; 1746 1747 Free (Parser); 1748 end if; 1749 end Set_Command_Line; 1750 1751 ---------------- 1752 -- Looking_At -- 1753 ---------------- 1754 1755 function Looking_At 1756 (Type_Str : String; 1757 Index : Natural; 1758 Substring : String) return Boolean 1759 is 1760 begin 1761 return Index + Substring'Length - 1 <= Type_Str'Last 1762 and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; 1763 end Looking_At; 1764 1765 ------------------------ 1766 -- Can_Have_Parameter -- 1767 ------------------------ 1768 1769 function Can_Have_Parameter (S : String) return Boolean is 1770 begin 1771 if S'Length <= 1 then 1772 return False; 1773 end if; 1774 1775 case S (S'Last) is 1776 when '!' | ':' | '?' | '=' => 1777 return True; 1778 when others => 1779 return False; 1780 end case; 1781 end Can_Have_Parameter; 1782 1783 ----------------------- 1784 -- Require_Parameter -- 1785 ----------------------- 1786 1787 function Require_Parameter (S : String) return Boolean is 1788 begin 1789 if S'Length <= 1 then 1790 return False; 1791 end if; 1792 1793 case S (S'Last) is 1794 when '!' | ':' | '=' => 1795 return True; 1796 when others => 1797 return False; 1798 end case; 1799 end Require_Parameter; 1800 1801 ------------------- 1802 -- Actual_Switch -- 1803 ------------------- 1804 1805 function Actual_Switch (S : String) return String is 1806 begin 1807 if S'Length <= 1 then 1808 return S; 1809 end if; 1810 1811 case S (S'Last) is 1812 when '!' | ':' | '?' | '=' => 1813 return S (S'First .. S'Last - 1); 1814 when others => 1815 return S; 1816 end case; 1817 end Actual_Switch; 1818 1819 ---------------------------- 1820 -- For_Each_Simple_Switch -- 1821 ---------------------------- 1822 1823 procedure For_Each_Simple_Switch 1824 (Config : Command_Line_Configuration; 1825 Section : String; 1826 Switch : String; 1827 Parameter : String := ""; 1828 Unalias : Boolean := True) 1829 is 1830 function Group_Analysis 1831 (Prefix : String; 1832 Group : String) return Boolean; 1833 -- Perform the analysis of a group of switches 1834 1835 Found_In_Config : Boolean := False; 1836 function Is_In_Config 1837 (Config_Switch : String; Index : Integer) return Boolean; 1838 -- If Switch is the same as Config_Switch, run the callback and sets 1839 -- Found_In_Config to True. 1840 1841 function Starts_With 1842 (Config_Switch : String; Index : Integer) return Boolean; 1843 -- if Switch starts with Config_Switch, sets Found_In_Config to True. 1844 -- The return value is for the Foreach_Switch iterator. 1845 1846 -------------------- 1847 -- Group_Analysis -- 1848 -------------------- 1849 1850 function Group_Analysis 1851 (Prefix : String; 1852 Group : String) return Boolean 1853 is 1854 Idx : Natural; 1855 Found : Boolean; 1856 1857 function Analyze_Simple_Switch 1858 (Switch : String; Index : Integer) return Boolean; 1859 -- "Switches" is one of the switch definitions passed to the 1860 -- configuration, not one of the switches found on the command line. 1861 1862 --------------------------- 1863 -- Analyze_Simple_Switch -- 1864 --------------------------- 1865 1866 function Analyze_Simple_Switch 1867 (Switch : String; Index : Integer) return Boolean 1868 is 1869 pragma Unreferenced (Index); 1870 1871 Full : constant String := Prefix & Group (Idx .. Group'Last); 1872 1873 Sw : constant String := Actual_Switch (Switch); 1874 -- Switches definition minus argument definition 1875 1876 Last : Natural; 1877 Param : Natural; 1878 1879 begin 1880 -- Verify that sw starts with Prefix 1881 1882 if Looking_At (Sw, Sw'First, Prefix) 1883 1884 -- Verify that the group starts with sw 1885 1886 and then Looking_At (Full, Full'First, Sw) 1887 then 1888 Last := Idx + Sw'Length - Prefix'Length - 1; 1889 Param := Last + 1; 1890 1891 if Can_Have_Parameter (Switch) then 1892 1893 -- Include potential parameter to the recursive call. Only 1894 -- numbers are allowed. 1895 1896 while Last < Group'Last 1897 and then Group (Last + 1) in '0' .. '9' 1898 loop 1899 Last := Last + 1; 1900 end loop; 1901 end if; 1902 1903 if not Require_Parameter (Switch) or else Last >= Param then 1904 if Idx = Group'First 1905 and then Last = Group'Last 1906 and then Last < Param 1907 then 1908 -- The group only concerns a single switch. Do not 1909 -- perform recursive call. 1910 1911 -- Note that we still perform a recursive call if 1912 -- a parameter is detected in the switch, as this 1913 -- is a way to correctly identify such a parameter 1914 -- in aliases. 1915 1916 return False; 1917 end if; 1918 1919 Found := True; 1920 1921 -- Recursive call, using the detected parameter if any 1922 1923 if Last >= Param then 1924 For_Each_Simple_Switch 1925 (Config, 1926 Section, 1927 Prefix & Group (Idx .. Param - 1), 1928 Group (Param .. Last)); 1929 1930 else 1931 For_Each_Simple_Switch 1932 (Config, Section, Prefix & Group (Idx .. Last), ""); 1933 end if; 1934 1935 Idx := Last + 1; 1936 return False; 1937 end if; 1938 end if; 1939 1940 return True; 1941 end Analyze_Simple_Switch; 1942 1943 procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch); 1944 1945 -- Start of processing for Group_Analysis 1946 1947 begin 1948 Idx := Group'First; 1949 while Idx <= Group'Last loop 1950 Found := False; 1951 Foreach (Config, Section); 1952 1953 if not Found then 1954 For_Each_Simple_Switch 1955 (Config, Section, Prefix & Group (Idx), ""); 1956 Idx := Idx + 1; 1957 end if; 1958 end loop; 1959 1960 return True; 1961 end Group_Analysis; 1962 1963 ------------------ 1964 -- Is_In_Config -- 1965 ------------------ 1966 1967 function Is_In_Config 1968 (Config_Switch : String; Index : Integer) return Boolean 1969 is 1970 Last : Natural; 1971 P : Switch_Parameter_Type; 1972 1973 begin 1974 Decompose_Switch (Config_Switch, P, Last); 1975 1976 if Config_Switch (Config_Switch'First .. Last) = Switch then 1977 case P is 1978 when Parameter_None => 1979 if Parameter = "" then 1980 Callback (Switch, "", "", Index => Index); 1981 Found_In_Config := True; 1982 return False; 1983 end if; 1984 1985 when Parameter_With_Optional_Space => 1986 Callback (Switch, " ", Parameter, Index => Index); 1987 Found_In_Config := True; 1988 return False; 1989 1990 when Parameter_With_Space_Or_Equal => 1991 Callback (Switch, "=", Parameter, Index => Index); 1992 Found_In_Config := True; 1993 return False; 1994 1995 when Parameter_No_Space => 1996 Callback (Switch, "", Parameter, Index); 1997 Found_In_Config := True; 1998 return False; 1999 2000 when Parameter_Optional => 2001 Callback (Switch, "", Parameter, Index); 2002 Found_In_Config := True; 2003 return False; 2004 end case; 2005 end if; 2006 2007 return True; 2008 end Is_In_Config; 2009 2010 ----------------- 2011 -- Starts_With -- 2012 ----------------- 2013 2014 function Starts_With 2015 (Config_Switch : String; Index : Integer) return Boolean 2016 is 2017 Last : Natural; 2018 Param : Natural; 2019 P : Switch_Parameter_Type; 2020 2021 begin 2022 -- This function is called when we believe the parameter was 2023 -- specified as part of the switch, instead of separately. Thus we 2024 -- look in the config to find all possible switches. 2025 2026 Decompose_Switch (Config_Switch, P, Last); 2027 2028 if Looking_At 2029 (Switch, Switch'First, 2030 Config_Switch (Config_Switch'First .. Last)) 2031 then 2032 -- Set first char of Param, and last char of Switch 2033 2034 Param := Switch'First + Last; 2035 Last := Switch'First + Last - Config_Switch'First; 2036 2037 case P is 2038 2039 -- None is already handled in Is_In_Config 2040 2041 when Parameter_None => 2042 null; 2043 2044 when Parameter_With_Space_Or_Equal => 2045 if Param <= Switch'Last 2046 and then 2047 (Switch (Param) = ' ' or else Switch (Param) = '=') 2048 then 2049 Callback (Switch (Switch'First .. Last), 2050 "=", Switch (Param + 1 .. Switch'Last), Index); 2051 Found_In_Config := True; 2052 return False; 2053 end if; 2054 2055 when Parameter_With_Optional_Space => 2056 if Param <= Switch'Last and then Switch (Param) = ' ' then 2057 Param := Param + 1; 2058 end if; 2059 2060 Callback (Switch (Switch'First .. Last), 2061 " ", Switch (Param .. Switch'Last), Index); 2062 Found_In_Config := True; 2063 return False; 2064 2065 when Parameter_No_Space | Parameter_Optional => 2066 Callback (Switch (Switch'First .. Last), 2067 "", Switch (Param .. Switch'Last), Index); 2068 Found_In_Config := True; 2069 return False; 2070 end case; 2071 end if; 2072 return True; 2073 end Starts_With; 2074 2075 procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config); 2076 procedure Foreach_Starts_With is new Foreach_Switch (Starts_With); 2077 2078 -- Start of processing for For_Each_Simple_Switch 2079 2080 begin 2081 -- First determine if the switch corresponds to one belonging to the 2082 -- configuration. If so, run callback and exit. 2083 2084 -- ??? Is this necessary. On simple tests, we seem to have the same 2085 -- results with or without this call. 2086 2087 Foreach_In_Config (Config, Section); 2088 2089 if Found_In_Config then 2090 return; 2091 end if; 2092 2093 -- If adding a switch that can in fact be expanded through aliases, 2094 -- add separately each of its expansions. 2095 2096 -- This takes care of expansions like "-T" -> "-gnatwrs", where the 2097 -- alias and its expansion do not have the same prefix. Given the order 2098 -- in which we do things here, the expansion of the alias will itself 2099 -- be checked for a common prefix and split into simple switches. 2100 2101 if Unalias 2102 and then Config /= null 2103 and then Config.Aliases /= null 2104 then 2105 for A in Config.Aliases'Range loop 2106 if Config.Aliases (A).Section.all = Section 2107 and then Config.Aliases (A).Alias.all = Switch 2108 and then Parameter = "" 2109 then 2110 For_Each_Simple_Switch 2111 (Config, Section, Config.Aliases (A).Expansion.all, ""); 2112 return; 2113 end if; 2114 end loop; 2115 end if; 2116 2117 -- If adding a switch grouping several switches, add each of the simple 2118 -- switches instead. 2119 2120 if Config /= null and then Config.Prefixes /= null then 2121 for P in Config.Prefixes'Range loop 2122 if Switch'Length > Config.Prefixes (P)'Length + 1 2123 and then 2124 Looking_At (Switch, Switch'First, Config.Prefixes (P).all) 2125 then 2126 -- Alias expansion will be done recursively 2127 2128 if Config.Switches = null then 2129 for S in Switch'First + Config.Prefixes (P)'Length 2130 .. Switch'Last 2131 loop 2132 For_Each_Simple_Switch 2133 (Config, Section, 2134 Config.Prefixes (P).all & Switch (S), ""); 2135 end loop; 2136 2137 return; 2138 2139 elsif Group_Analysis 2140 (Config.Prefixes (P).all, 2141 Switch 2142 (Switch'First + Config.Prefixes (P)'Length .. Switch'Last)) 2143 then 2144 -- Recursive calls already done on each switch of the group: 2145 -- Return without executing Callback. 2146 2147 return; 2148 end if; 2149 end if; 2150 end loop; 2151 end if; 2152 2153 -- Test if added switch is a known switch with parameter attached 2154 -- instead of being specified separately 2155 2156 if Parameter = "" 2157 and then Config /= null 2158 and then Config.Switches /= null 2159 then 2160 Found_In_Config := False; 2161 Foreach_Starts_With (Config, Section); 2162 2163 if Found_In_Config then 2164 return; 2165 end if; 2166 end if; 2167 2168 -- The switch is invalid in the config, but we still want to report it. 2169 -- The config could, for instance, include "*" to specify it accepts 2170 -- all switches. 2171 2172 Callback (Switch, " ", Parameter, Index => -1); 2173 end For_Each_Simple_Switch; 2174 2175 ---------------- 2176 -- Add_Switch -- 2177 ---------------- 2178 2179 procedure Add_Switch 2180 (Cmd : in out Command_Line; 2181 Switch : String; 2182 Parameter : String := ""; 2183 Separator : Character := ASCII.NUL; 2184 Section : String := ""; 2185 Add_Before : Boolean := False) 2186 is 2187 Success : Boolean; 2188 pragma Unreferenced (Success); 2189 begin 2190 Add_Switch (Cmd, Switch, Parameter, Separator, 2191 Section, Add_Before, Success); 2192 end Add_Switch; 2193 2194 ---------------- 2195 -- Add_Switch -- 2196 ---------------- 2197 2198 procedure Add_Switch 2199 (Cmd : in out Command_Line; 2200 Switch : String; 2201 Parameter : String := ""; 2202 Separator : Character := ASCII.NUL; 2203 Section : String := ""; 2204 Add_Before : Boolean := False; 2205 Success : out Boolean) 2206 is 2207 procedure Add_Simple_Switch 2208 (Simple : String; 2209 Sepa : String; 2210 Param : String; 2211 Index : Integer); 2212 -- Add a new switch that has had all its aliases expanded, and switches 2213 -- ungrouped. We know there are no more aliases in Switches. 2214 2215 ----------------------- 2216 -- Add_Simple_Switch -- 2217 ----------------------- 2218 2219 procedure Add_Simple_Switch 2220 (Simple : String; 2221 Sepa : String; 2222 Param : String; 2223 Index : Integer) 2224 is 2225 Sep : Character; 2226 2227 begin 2228 if Index = -1 2229 and then Cmd.Config /= null 2230 and then not Cmd.Config.Star_Switch 2231 then 2232 raise Invalid_Switch 2233 with "Invalid switch " & Simple; 2234 end if; 2235 2236 if Separator /= ASCII.NUL then 2237 Sep := Separator; 2238 2239 elsif Sepa = "" then 2240 Sep := ASCII.NUL; 2241 else 2242 Sep := Sepa (Sepa'First); 2243 end if; 2244 2245 if Cmd.Expanded = null then 2246 Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); 2247 2248 if Param /= "" then 2249 Cmd.Params := 2250 new Argument_List'(1 .. 1 => new String'(Sep & Param)); 2251 else 2252 Cmd.Params := new Argument_List'(1 .. 1 => null); 2253 end if; 2254 2255 if Section = "" then 2256 Cmd.Sections := new Argument_List'(1 .. 1 => null); 2257 else 2258 Cmd.Sections := 2259 new Argument_List'(1 .. 1 => new String'(Section)); 2260 end if; 2261 2262 else 2263 -- Do we already have this switch? 2264 2265 for C in Cmd.Expanded'Range loop 2266 if Cmd.Expanded (C).all = Simple 2267 and then 2268 ((Cmd.Params (C) = null and then Param = "") 2269 or else 2270 (Cmd.Params (C) /= null 2271 and then Cmd.Params (C).all = Sep & Param)) 2272 and then 2273 ((Cmd.Sections (C) = null and then Section = "") 2274 or else 2275 (Cmd.Sections (C) /= null 2276 and then Cmd.Sections (C).all = Section)) 2277 then 2278 return; 2279 end if; 2280 end loop; 2281 2282 -- Inserting at least one switch 2283 2284 Success := True; 2285 Add (Cmd.Expanded, new String'(Simple), Add_Before); 2286 2287 if Param /= "" then 2288 Add 2289 (Cmd.Params, 2290 new String'(Sep & Param), 2291 Add_Before); 2292 else 2293 Add 2294 (Cmd.Params, 2295 null, 2296 Add_Before); 2297 end if; 2298 2299 if Section = "" then 2300 Add 2301 (Cmd.Sections, 2302 null, 2303 Add_Before); 2304 else 2305 Add 2306 (Cmd.Sections, 2307 new String'(Section), 2308 Add_Before); 2309 end if; 2310 end if; 2311 end Add_Simple_Switch; 2312 2313 procedure Add_Simple_Switches is 2314 new For_Each_Simple_Switch (Add_Simple_Switch); 2315 2316 -- Local Variables 2317 2318 Section_Valid : Boolean := False; 2319 2320 -- Start of processing for Add_Switch 2321 2322 begin 2323 if Section /= "" and then Cmd.Config /= null then 2324 for S in Cmd.Config.Sections'Range loop 2325 if Section = Cmd.Config.Sections (S).all then 2326 Section_Valid := True; 2327 exit; 2328 end if; 2329 end loop; 2330 2331 if not Section_Valid then 2332 raise Invalid_Section; 2333 end if; 2334 end if; 2335 2336 Success := False; 2337 Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter); 2338 Free (Cmd.Coalesce); 2339 end Add_Switch; 2340 2341 ------------ 2342 -- Remove -- 2343 ------------ 2344 2345 procedure Remove (Line : in out Argument_List_Access; Index : Integer) is 2346 Tmp : Argument_List_Access := Line; 2347 2348 begin 2349 Line := new Argument_List (Tmp'First .. Tmp'Last - 1); 2350 2351 if Index /= Tmp'First then 2352 Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1); 2353 end if; 2354 2355 Free (Tmp (Index)); 2356 2357 if Index /= Tmp'Last then 2358 Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last); 2359 end if; 2360 2361 Unchecked_Free (Tmp); 2362 end Remove; 2363 2364 --------- 2365 -- Add -- 2366 --------- 2367 2368 procedure Add 2369 (Line : in out Argument_List_Access; 2370 Str : String_Access; 2371 Before : Boolean := False) 2372 is 2373 Tmp : Argument_List_Access := Line; 2374 2375 begin 2376 if Tmp /= null then 2377 Line := new Argument_List (Tmp'First .. Tmp'Last + 1); 2378 2379 if Before then 2380 Line (Tmp'First) := Str; 2381 Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; 2382 else 2383 Line (Tmp'Range) := Tmp.all; 2384 Line (Tmp'Last + 1) := Str; 2385 end if; 2386 2387 Unchecked_Free (Tmp); 2388 2389 else 2390 Line := new Argument_List'(1 .. 1 => Str); 2391 end if; 2392 end Add; 2393 2394 ------------------- 2395 -- Remove_Switch -- 2396 ------------------- 2397 2398 procedure Remove_Switch 2399 (Cmd : in out Command_Line; 2400 Switch : String; 2401 Remove_All : Boolean := False; 2402 Has_Parameter : Boolean := False; 2403 Section : String := "") 2404 is 2405 Success : Boolean; 2406 pragma Unreferenced (Success); 2407 begin 2408 Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success); 2409 end Remove_Switch; 2410 2411 ------------------- 2412 -- Remove_Switch -- 2413 ------------------- 2414 2415 procedure Remove_Switch 2416 (Cmd : in out Command_Line; 2417 Switch : String; 2418 Remove_All : Boolean := False; 2419 Has_Parameter : Boolean := False; 2420 Section : String := ""; 2421 Success : out Boolean) 2422 is 2423 procedure Remove_Simple_Switch 2424 (Simple, Separator, Param : String; Index : Integer); 2425 -- Removes a simple switch, with no aliasing or grouping 2426 2427 -------------------------- 2428 -- Remove_Simple_Switch -- 2429 -------------------------- 2430 2431 procedure Remove_Simple_Switch 2432 (Simple, Separator, Param : String; Index : Integer) 2433 is 2434 C : Integer; 2435 pragma Unreferenced (Param, Separator, Index); 2436 2437 begin 2438 if Cmd.Expanded /= null then 2439 C := Cmd.Expanded'First; 2440 while C <= Cmd.Expanded'Last loop 2441 if Cmd.Expanded (C).all = Simple 2442 and then 2443 (Remove_All 2444 or else (Cmd.Sections (C) = null 2445 and then Section = "") 2446 or else (Cmd.Sections (C) /= null 2447 and then Section = Cmd.Sections (C).all)) 2448 and then (not Has_Parameter or else Cmd.Params (C) /= null) 2449 then 2450 Remove (Cmd.Expanded, C); 2451 Remove (Cmd.Params, C); 2452 Remove (Cmd.Sections, C); 2453 Success := True; 2454 2455 if not Remove_All then 2456 return; 2457 end if; 2458 2459 else 2460 C := C + 1; 2461 end if; 2462 end loop; 2463 end if; 2464 end Remove_Simple_Switch; 2465 2466 procedure Remove_Simple_Switches is 2467 new For_Each_Simple_Switch (Remove_Simple_Switch); 2468 2469 -- Start of processing for Remove_Switch 2470 2471 begin 2472 Success := False; 2473 Remove_Simple_Switches 2474 (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter); 2475 Free (Cmd.Coalesce); 2476 end Remove_Switch; 2477 2478 ------------------- 2479 -- Remove_Switch -- 2480 ------------------- 2481 2482 procedure Remove_Switch 2483 (Cmd : in out Command_Line; 2484 Switch : String; 2485 Parameter : String; 2486 Section : String := "") 2487 is 2488 procedure Remove_Simple_Switch 2489 (Simple, Separator, Param : String; Index : Integer); 2490 -- Removes a simple switch, with no aliasing or grouping 2491 2492 -------------------------- 2493 -- Remove_Simple_Switch -- 2494 -------------------------- 2495 2496 procedure Remove_Simple_Switch 2497 (Simple, Separator, Param : String; Index : Integer) 2498 is 2499 pragma Unreferenced (Separator, Index); 2500 C : Integer; 2501 2502 begin 2503 if Cmd.Expanded /= null then 2504 C := Cmd.Expanded'First; 2505 while C <= Cmd.Expanded'Last loop 2506 if Cmd.Expanded (C).all = Simple 2507 and then 2508 ((Cmd.Sections (C) = null 2509 and then Section = "") 2510 or else 2511 (Cmd.Sections (C) /= null 2512 and then Section = Cmd.Sections (C).all)) 2513 and then 2514 ((Cmd.Params (C) = null and then Param = "") 2515 or else 2516 (Cmd.Params (C) /= null 2517 2518 -- Ignore the separator stored in Parameter 2519 2520 and then 2521 Cmd.Params (C) (Cmd.Params (C)'First + 1 2522 .. Cmd.Params (C)'Last) = Param)) 2523 then 2524 Remove (Cmd.Expanded, C); 2525 Remove (Cmd.Params, C); 2526 Remove (Cmd.Sections, C); 2527 2528 -- The switch is necessarily unique by construction of 2529 -- Add_Switch. 2530 2531 return; 2532 2533 else 2534 C := C + 1; 2535 end if; 2536 end loop; 2537 end if; 2538 end Remove_Simple_Switch; 2539 2540 procedure Remove_Simple_Switches is 2541 new For_Each_Simple_Switch (Remove_Simple_Switch); 2542 2543 -- Start of processing for Remove_Switch 2544 2545 begin 2546 Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter); 2547 Free (Cmd.Coalesce); 2548 end Remove_Switch; 2549 2550 -------------------- 2551 -- Group_Switches -- 2552 -------------------- 2553 2554 procedure Group_Switches 2555 (Cmd : Command_Line; 2556 Result : Argument_List_Access; 2557 Sections : Argument_List_Access; 2558 Params : Argument_List_Access) 2559 is 2560 function Compatible_Parameter (Param : String_Access) return Boolean; 2561 -- True when the parameter can be part of a group 2562 2563 -------------------------- 2564 -- Compatible_Parameter -- 2565 -------------------------- 2566 2567 function Compatible_Parameter (Param : String_Access) return Boolean is 2568 begin 2569 -- No parameter OK 2570 2571 if Param = null then 2572 return True; 2573 2574 -- We need parameters without separators 2575 2576 elsif Param (Param'First) /= ASCII.NUL then 2577 return False; 2578 2579 -- Parameters must be all digits 2580 2581 else 2582 for J in Param'First + 1 .. Param'Last loop 2583 if Param (J) not in '0' .. '9' then 2584 return False; 2585 end if; 2586 end loop; 2587 2588 return True; 2589 end if; 2590 end Compatible_Parameter; 2591 2592 -- Local declarations 2593 2594 Group : Ada.Strings.Unbounded.Unbounded_String; 2595 First : Natural; 2596 use type Ada.Strings.Unbounded.Unbounded_String; 2597 2598 -- Start of processing for Group_Switches 2599 2600 begin 2601 if Cmd.Config = null or else Cmd.Config.Prefixes = null then 2602 return; 2603 end if; 2604 2605 for P in Cmd.Config.Prefixes'Range loop 2606 Group := Ada.Strings.Unbounded.Null_Unbounded_String; 2607 First := 0; 2608 2609 for C in Result'Range loop 2610 if Result (C) /= null 2611 and then Compatible_Parameter (Params (C)) 2612 and then Looking_At 2613 (Result (C).all, 2614 Result (C)'First, 2615 Cmd.Config.Prefixes (P).all) 2616 then 2617 -- If we are still in the same section, group the switches 2618 2619 if First = 0 2620 or else 2621 (Sections (C) = null 2622 and then Sections (First) = null) 2623 or else 2624 (Sections (C) /= null 2625 and then Sections (First) /= null 2626 and then Sections (C).all = Sections (First).all) 2627 then 2628 Group := 2629 Group & 2630 Result (C) 2631 (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. 2632 Result (C)'Last); 2633 2634 if Params (C) /= null then 2635 Group := 2636 Group & 2637 Params (C) (Params (C)'First + 1 .. Params (C)'Last); 2638 Free (Params (C)); 2639 end if; 2640 2641 if First = 0 then 2642 First := C; 2643 end if; 2644 2645 Free (Result (C)); 2646 2647 -- We changed section: we put the grouped switches to the first 2648 -- place, on continue with the new section. 2649 2650 else 2651 Result (First) := 2652 new String' 2653 (Cmd.Config.Prefixes (P).all & 2654 Ada.Strings.Unbounded.To_String (Group)); 2655 Group := 2656 Ada.Strings.Unbounded.To_Unbounded_String 2657 (Result (C) 2658 (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. 2659 Result (C)'Last)); 2660 First := C; 2661 end if; 2662 end if; 2663 end loop; 2664 2665 if First > 0 then 2666 Result (First) := 2667 new String' 2668 (Cmd.Config.Prefixes (P).all & 2669 Ada.Strings.Unbounded.To_String (Group)); 2670 end if; 2671 end loop; 2672 end Group_Switches; 2673 2674 -------------------- 2675 -- Alias_Switches -- 2676 -------------------- 2677 2678 procedure Alias_Switches 2679 (Cmd : Command_Line; 2680 Result : Argument_List_Access; 2681 Params : Argument_List_Access) 2682 is 2683 Found : Boolean; 2684 First : Natural; 2685 2686 procedure Check_Cb (Switch, Separator, Param : String; Index : Integer); 2687 -- Checks whether the command line contains [Switch]. Sets the global 2688 -- variable [Found] appropriately. This is called for each simple switch 2689 -- that make up an alias, to know whether the alias should be applied. 2690 2691 procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer); 2692 -- Remove the simple switch [Switch] from the command line, since it is 2693 -- part of a simpler alias 2694 2695 -------------- 2696 -- Check_Cb -- 2697 -------------- 2698 2699 procedure Check_Cb 2700 (Switch, Separator, Param : String; Index : Integer) 2701 is 2702 pragma Unreferenced (Separator, Index); 2703 2704 begin 2705 if Found then 2706 for E in Result'Range loop 2707 if Result (E) /= null 2708 and then 2709 (Params (E) = null 2710 or else Params (E) (Params (E)'First + 1 .. 2711 Params (E)'Last) = Param) 2712 and then Result (E).all = Switch 2713 then 2714 return; 2715 end if; 2716 end loop; 2717 2718 Found := False; 2719 end if; 2720 end Check_Cb; 2721 2722 --------------- 2723 -- Remove_Cb -- 2724 --------------- 2725 2726 procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer) 2727 is 2728 pragma Unreferenced (Separator, Index); 2729 2730 begin 2731 for E in Result'Range loop 2732 if Result (E) /= null 2733 and then 2734 (Params (E) = null 2735 or else Params (E) (Params (E)'First + 1 2736 .. Params (E)'Last) = Param) 2737 and then Result (E).all = Switch 2738 then 2739 if First > E then 2740 First := E; 2741 end if; 2742 2743 Free (Result (E)); 2744 Free (Params (E)); 2745 return; 2746 end if; 2747 end loop; 2748 end Remove_Cb; 2749 2750 procedure Check_All is new For_Each_Simple_Switch (Check_Cb); 2751 procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb); 2752 2753 -- Start of processing for Alias_Switches 2754 2755 begin 2756 if Cmd.Config = null or else Cmd.Config.Aliases = null then 2757 return; 2758 end if; 2759 2760 for A in Cmd.Config.Aliases'Range loop 2761 2762 -- Compute the various simple switches that make up the alias. We 2763 -- split the expansion into as many simple switches as possible, and 2764 -- then check whether the expanded command line has all of them. 2765 2766 Found := True; 2767 Check_All (Cmd.Config, 2768 Switch => Cmd.Config.Aliases (A).Expansion.all, 2769 Section => Cmd.Config.Aliases (A).Section.all); 2770 2771 if Found then 2772 First := Integer'Last; 2773 Remove_All (Cmd.Config, 2774 Switch => Cmd.Config.Aliases (A).Expansion.all, 2775 Section => Cmd.Config.Aliases (A).Section.all); 2776 Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all); 2777 end if; 2778 end loop; 2779 end Alias_Switches; 2780 2781 ------------------- 2782 -- Sort_Sections -- 2783 ------------------- 2784 2785 procedure Sort_Sections 2786 (Line : GNAT.OS_Lib.Argument_List_Access; 2787 Sections : GNAT.OS_Lib.Argument_List_Access; 2788 Params : GNAT.OS_Lib.Argument_List_Access) 2789 is 2790 Sections_List : Argument_List_Access := 2791 new Argument_List'(1 .. 1 => null); 2792 Found : Boolean; 2793 Old_Line : constant Argument_List := Line.all; 2794 Old_Sections : constant Argument_List := Sections.all; 2795 Old_Params : constant Argument_List := Params.all; 2796 Index : Natural; 2797 2798 begin 2799 if Line = null then 2800 return; 2801 end if; 2802 2803 -- First construct a list of all sections 2804 2805 for E in Line'Range loop 2806 if Sections (E) /= null then 2807 Found := False; 2808 for S in Sections_List'Range loop 2809 if (Sections_List (S) = null and then Sections (E) = null) 2810 or else 2811 (Sections_List (S) /= null 2812 and then Sections (E) /= null 2813 and then Sections_List (S).all = Sections (E).all) 2814 then 2815 Found := True; 2816 exit; 2817 end if; 2818 end loop; 2819 2820 if not Found then 2821 Add (Sections_List, Sections (E)); 2822 end if; 2823 end if; 2824 end loop; 2825 2826 Index := Line'First; 2827 2828 for S in Sections_List'Range loop 2829 for E in Old_Line'Range loop 2830 if (Sections_List (S) = null and then Old_Sections (E) = null) 2831 or else 2832 (Sections_List (S) /= null 2833 and then Old_Sections (E) /= null 2834 and then Sections_List (S).all = Old_Sections (E).all) 2835 then 2836 Line (Index) := Old_Line (E); 2837 Sections (Index) := Old_Sections (E); 2838 Params (Index) := Old_Params (E); 2839 Index := Index + 1; 2840 end if; 2841 end loop; 2842 end loop; 2843 2844 Unchecked_Free (Sections_List); 2845 end Sort_Sections; 2846 2847 ----------- 2848 -- Start -- 2849 ----------- 2850 2851 procedure Start 2852 (Cmd : in out Command_Line; 2853 Iter : in out Command_Line_Iterator; 2854 Expanded : Boolean := False) 2855 is 2856 begin 2857 if Cmd.Expanded = null then 2858 Iter.List := null; 2859 return; 2860 end if; 2861 2862 -- Reorder the expanded line so that sections are grouped 2863 2864 Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params); 2865 2866 -- Coalesce the switches as much as possible 2867 2868 if not Expanded 2869 and then Cmd.Coalesce = null 2870 then 2871 Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range); 2872 for E in Cmd.Expanded'Range loop 2873 Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); 2874 end loop; 2875 2876 Free (Cmd.Coalesce_Sections); 2877 Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); 2878 for E in Cmd.Sections'Range loop 2879 Cmd.Coalesce_Sections (E) := 2880 (if Cmd.Sections (E) = null then null 2881 else new String'(Cmd.Sections (E).all)); 2882 end loop; 2883 2884 Free (Cmd.Coalesce_Params); 2885 Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); 2886 for E in Cmd.Params'Range loop 2887 Cmd.Coalesce_Params (E) := 2888 (if Cmd.Params (E) = null then null 2889 else new String'(Cmd.Params (E).all)); 2890 end loop; 2891 2892 -- Not a clone, since we will not modify the parameters anyway 2893 2894 Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params); 2895 Group_Switches 2896 (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params); 2897 end if; 2898 2899 if Expanded then 2900 Iter.List := Cmd.Expanded; 2901 Iter.Params := Cmd.Params; 2902 Iter.Sections := Cmd.Sections; 2903 else 2904 Iter.List := Cmd.Coalesce; 2905 Iter.Params := Cmd.Coalesce_Params; 2906 Iter.Sections := Cmd.Coalesce_Sections; 2907 end if; 2908 2909 if Iter.List = null then 2910 Iter.Current := Integer'Last; 2911 else 2912 Iter.Current := Iter.List'First - 1; 2913 Next (Iter); 2914 end if; 2915 end Start; 2916 2917 -------------------- 2918 -- Current_Switch -- 2919 -------------------- 2920 2921 function Current_Switch (Iter : Command_Line_Iterator) return String is 2922 begin 2923 return Iter.List (Iter.Current).all; 2924 end Current_Switch; 2925 2926 -------------------- 2927 -- Is_New_Section -- 2928 -------------------- 2929 2930 function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is 2931 Section : constant String := Current_Section (Iter); 2932 2933 begin 2934 if Iter.Sections = null then 2935 return False; 2936 2937 elsif Iter.Current = Iter.Sections'First 2938 or else Iter.Sections (Iter.Current - 1) = null 2939 then 2940 return Section /= ""; 2941 2942 else 2943 return Section /= Iter.Sections (Iter.Current - 1).all; 2944 end if; 2945 end Is_New_Section; 2946 2947 --------------------- 2948 -- Current_Section -- 2949 --------------------- 2950 2951 function Current_Section (Iter : Command_Line_Iterator) return String is 2952 begin 2953 if Iter.Sections = null 2954 or else Iter.Current > Iter.Sections'Last 2955 or else Iter.Sections (Iter.Current) = null 2956 then 2957 return ""; 2958 end if; 2959 2960 return Iter.Sections (Iter.Current).all; 2961 end Current_Section; 2962 2963 ----------------------- 2964 -- Current_Separator -- 2965 ----------------------- 2966 2967 function Current_Separator (Iter : Command_Line_Iterator) return String is 2968 begin 2969 if Iter.Params = null 2970 or else Iter.Current > Iter.Params'Last 2971 or else Iter.Params (Iter.Current) = null 2972 then 2973 return ""; 2974 2975 else 2976 declare 2977 Sep : constant Character := 2978 Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First); 2979 begin 2980 if Sep = ASCII.NUL then 2981 return ""; 2982 else 2983 return "" & Sep; 2984 end if; 2985 end; 2986 end if; 2987 end Current_Separator; 2988 2989 ----------------------- 2990 -- Current_Parameter -- 2991 ----------------------- 2992 2993 function Current_Parameter (Iter : Command_Line_Iterator) return String is 2994 begin 2995 if Iter.Params = null 2996 or else Iter.Current > Iter.Params'Last 2997 or else Iter.Params (Iter.Current) = null 2998 then 2999 return ""; 3000 3001 else 3002 -- Return result, skipping separator 3003 3004 declare 3005 P : constant String := Iter.Params (Iter.Current).all; 3006 begin 3007 return P (P'First + 1 .. P'Last); 3008 end; 3009 end if; 3010 end Current_Parameter; 3011 3012 -------------- 3013 -- Has_More -- 3014 -------------- 3015 3016 function Has_More (Iter : Command_Line_Iterator) return Boolean is 3017 begin 3018 return Iter.List /= null and then Iter.Current <= Iter.List'Last; 3019 end Has_More; 3020 3021 ---------- 3022 -- Next -- 3023 ---------- 3024 3025 procedure Next (Iter : in out Command_Line_Iterator) is 3026 begin 3027 Iter.Current := Iter.Current + 1; 3028 while Iter.Current <= Iter.List'Last 3029 and then Iter.List (Iter.Current) = null 3030 loop 3031 Iter.Current := Iter.Current + 1; 3032 end loop; 3033 end Next; 3034 3035 ---------- 3036 -- Free -- 3037 ---------- 3038 3039 procedure Free (Config : in out Command_Line_Configuration) is 3040 procedure Unchecked_Free is new 3041 Ada.Unchecked_Deallocation 3042 (Switch_Definitions, Switch_Definitions_List); 3043 3044 procedure Unchecked_Free is new 3045 Ada.Unchecked_Deallocation 3046 (Alias_Definitions, Alias_Definitions_List); 3047 3048 begin 3049 if Config /= null then 3050 Free (Config.Prefixes); 3051 Free (Config.Sections); 3052 Free (Config.Usage); 3053 Free (Config.Help); 3054 Free (Config.Help_Msg); 3055 3056 if Config.Aliases /= null then 3057 for A in Config.Aliases'Range loop 3058 Free (Config.Aliases (A).Alias); 3059 Free (Config.Aliases (A).Expansion); 3060 Free (Config.Aliases (A).Section); 3061 end loop; 3062 3063 Unchecked_Free (Config.Aliases); 3064 end if; 3065 3066 if Config.Switches /= null then 3067 for S in Config.Switches'Range loop 3068 Free (Config.Switches (S).Switch); 3069 Free (Config.Switches (S).Long_Switch); 3070 Free (Config.Switches (S).Help); 3071 Free (Config.Switches (S).Section); 3072 end loop; 3073 3074 Unchecked_Free (Config.Switches); 3075 end if; 3076 3077 Unchecked_Free (Config); 3078 end if; 3079 end Free; 3080 3081 ---------- 3082 -- Free -- 3083 ---------- 3084 3085 procedure Free (Cmd : in out Command_Line) is 3086 begin 3087 Free (Cmd.Expanded); 3088 Free (Cmd.Coalesce); 3089 Free (Cmd.Coalesce_Sections); 3090 Free (Cmd.Coalesce_Params); 3091 Free (Cmd.Params); 3092 Free (Cmd.Sections); 3093 end Free; 3094 3095 --------------- 3096 -- Set_Usage -- 3097 --------------- 3098 3099 procedure Set_Usage 3100 (Config : in out Command_Line_Configuration; 3101 Usage : String := "[switches] [arguments]"; 3102 Help : String := ""; 3103 Help_Msg : String := "") 3104 is 3105 begin 3106 if Config = null then 3107 Config := new Command_Line_Configuration_Record; 3108 end if; 3109 3110 Free (Config.Usage); 3111 Free (Config.Help); 3112 Free (Config.Help_Msg); 3113 3114 Config.Usage := new String'(Usage); 3115 Config.Help := new String'(Help); 3116 Config.Help_Msg := new String'(Help_Msg); 3117 end Set_Usage; 3118 3119 ------------------ 3120 -- Display_Help -- 3121 ------------------ 3122 3123 procedure Display_Help (Config : Command_Line_Configuration) is 3124 function Switch_Name 3125 (Def : Switch_Definition; 3126 Section : String) return String; 3127 -- Return the "-short, --long=ARG" string for Def. 3128 -- Returns "" if the switch is not in the section. 3129 3130 function Param_Name 3131 (P : Switch_Parameter_Type; 3132 Name : String := "ARG") return String; 3133 -- Return the display for a switch parameter 3134 3135 procedure Display_Section_Help (Section : String); 3136 -- Display the help for a specific section ("" is the default section) 3137 3138 -------------------------- 3139 -- Display_Section_Help -- 3140 -------------------------- 3141 3142 procedure Display_Section_Help (Section : String) is 3143 Max_Len : Natural := 0; 3144 3145 begin 3146 -- ??? Special display for "*" 3147 3148 New_Line; 3149 3150 if Section /= "" then 3151 Put_Line ("Switches after " & Section); 3152 end if; 3153 3154 -- Compute size of the switches column 3155 3156 for S in Config.Switches'Range loop 3157 Max_Len := Natural'Max 3158 (Max_Len, Switch_Name (Config.Switches (S), Section)'Length); 3159 end loop; 3160 3161 if Config.Aliases /= null then 3162 for A in Config.Aliases'Range loop 3163 if Config.Aliases (A).Section.all = Section then 3164 Max_Len := Natural'Max 3165 (Max_Len, Config.Aliases (A).Alias'Length); 3166 end if; 3167 end loop; 3168 end if; 3169 3170 -- Display the switches 3171 3172 for S in Config.Switches'Range loop 3173 declare 3174 N : constant String := 3175 Switch_Name (Config.Switches (S), Section); 3176 3177 begin 3178 if N /= "" then 3179 Put (" "); 3180 Put (N); 3181 Put ((1 .. Max_Len - N'Length + 1 => ' ')); 3182 3183 if Config.Switches (S).Help /= null then 3184 Put (Config.Switches (S).Help.all); 3185 end if; 3186 3187 New_Line; 3188 end if; 3189 end; 3190 end loop; 3191 3192 -- Display the aliases 3193 3194 if Config.Aliases /= null then 3195 for A in Config.Aliases'Range loop 3196 if Config.Aliases (A).Section.all = Section then 3197 Put (" "); 3198 Put (Config.Aliases (A).Alias.all); 3199 Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1 3200 => ' ')); 3201 Put ("Equivalent to " & Config.Aliases (A).Expansion.all); 3202 New_Line; 3203 end if; 3204 end loop; 3205 end if; 3206 end Display_Section_Help; 3207 3208 ---------------- 3209 -- Param_Name -- 3210 ---------------- 3211 3212 function Param_Name 3213 (P : Switch_Parameter_Type; 3214 Name : String := "ARG") return String 3215 is 3216 begin 3217 case P is 3218 when Parameter_None => 3219 return ""; 3220 3221 when Parameter_With_Optional_Space => 3222 return " " & To_Upper (Name); 3223 3224 when Parameter_With_Space_Or_Equal => 3225 return "=" & To_Upper (Name); 3226 3227 when Parameter_No_Space => 3228 return To_Upper (Name); 3229 3230 when Parameter_Optional => 3231 return '[' & To_Upper (Name) & ']'; 3232 end case; 3233 end Param_Name; 3234 3235 ----------------- 3236 -- Switch_Name -- 3237 ----------------- 3238 3239 function Switch_Name 3240 (Def : Switch_Definition; 3241 Section : String) return String 3242 is 3243 use Ada.Strings.Unbounded; 3244 Result : Unbounded_String; 3245 P1, P2 : Switch_Parameter_Type; 3246 Last1, Last2 : Integer := 0; 3247 3248 begin 3249 if (Section = "" and then Def.Section = null) 3250 or else (Def.Section /= null and then Def.Section.all = Section) 3251 then 3252 if Def.Switch /= null and then Def.Switch.all = "*" then 3253 return "[any switch]"; 3254 end if; 3255 3256 if Def.Switch /= null then 3257 Decompose_Switch (Def.Switch.all, P1, Last1); 3258 Append (Result, Def.Switch (Def.Switch'First .. Last1)); 3259 3260 if Def.Long_Switch /= null then 3261 Decompose_Switch (Def.Long_Switch.all, P2, Last2); 3262 Append (Result, ", " 3263 & Def.Long_Switch (Def.Long_Switch'First .. Last2)); 3264 3265 if Def.Argument = null then 3266 Append (Result, Param_Name (P2, "ARG")); 3267 else 3268 Append (Result, Param_Name (P2, Def.Argument.all)); 3269 end if; 3270 3271 else 3272 if Def.Argument = null then 3273 Append (Result, Param_Name (P1, "ARG")); 3274 else 3275 Append (Result, Param_Name (P1, Def.Argument.all)); 3276 end if; 3277 end if; 3278 3279 -- Def.Switch is null (Long_Switch must be non-null) 3280 3281 else 3282 Decompose_Switch (Def.Long_Switch.all, P2, Last2); 3283 Append (Result, 3284 Def.Long_Switch (Def.Long_Switch'First .. Last2)); 3285 3286 if Def.Argument = null then 3287 Append (Result, Param_Name (P2, "ARG")); 3288 else 3289 Append (Result, Param_Name (P2, Def.Argument.all)); 3290 end if; 3291 end if; 3292 end if; 3293 3294 return To_String (Result); 3295 end Switch_Name; 3296 3297 -- Start of processing for Display_Help 3298 3299 begin 3300 if Config = null then 3301 return; 3302 end if; 3303 3304 if Config.Help /= null and then Config.Help.all /= "" then 3305 Put_Line (Config.Help.all); 3306 end if; 3307 3308 if Config.Usage /= null then 3309 Put_Line ("Usage: " 3310 & Base_Name 3311 (Ada.Command_Line.Command_Name) & " " & Config.Usage.all); 3312 else 3313 Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name) 3314 & " [switches] [arguments]"); 3315 end if; 3316 3317 if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then 3318 Put_Line (Config.Help_Msg.all); 3319 3320 else 3321 Display_Section_Help (""); 3322 3323 if Config.Sections /= null and then Config.Switches /= null then 3324 for S in Config.Sections'Range loop 3325 Display_Section_Help (Config.Sections (S).all); 3326 end loop; 3327 end if; 3328 end if; 3329 end Display_Help; 3330 3331 ------------ 3332 -- Getopt -- 3333 ------------ 3334 3335 procedure Getopt 3336 (Config : Command_Line_Configuration; 3337 Callback : Switch_Handler := null; 3338 Parser : Opt_Parser := Command_Line_Parser; 3339 Concatenate : Boolean := True) 3340 is 3341 Getopt_Switches : String_Access; 3342 C : Character := ASCII.NUL; 3343 3344 Empty_Name : aliased constant String := ""; 3345 Current_Section : Integer := -1; 3346 Section_Name : not null access constant String := Empty_Name'Access; 3347 3348 procedure Simple_Callback 3349 (Simple_Switch : String; 3350 Separator : String; 3351 Parameter : String; 3352 Index : Integer); 3353 -- Needs comments ??? 3354 3355 procedure Do_Callback (Switch, Parameter : String; Index : Integer); 3356 3357 ----------------- 3358 -- Do_Callback -- 3359 ----------------- 3360 3361 procedure Do_Callback (Switch, Parameter : String; Index : Integer) is 3362 begin 3363 -- Do automatic handling when possible 3364 3365 if Index /= -1 then 3366 case Config.Switches (Index).Typ is 3367 when Switch_Untyped => 3368 null; -- no automatic handling 3369 3370 when Switch_Boolean => 3371 Config.Switches (Index).Boolean_Output.all := 3372 Config.Switches (Index).Boolean_Value; 3373 return; 3374 3375 when Switch_Integer => 3376 begin 3377 if Parameter = "" then 3378 Config.Switches (Index).Integer_Output.all := 3379 Config.Switches (Index).Integer_Default; 3380 else 3381 Config.Switches (Index).Integer_Output.all := 3382 Integer'Value (Parameter); 3383 end if; 3384 3385 exception 3386 when Constraint_Error => 3387 raise Invalid_Parameter 3388 with "Expected integer parameter for '" 3389 & Switch & "'"; 3390 end; 3391 3392 return; 3393 3394 when Switch_String => 3395 Free (Config.Switches (Index).String_Output.all); 3396 Config.Switches (Index).String_Output.all := 3397 new String'(Parameter); 3398 return; 3399 3400 end case; 3401 end if; 3402 3403 -- Otherwise calls the user callback if one was defined 3404 3405 if Callback /= null then 3406 Callback (Switch => Switch, 3407 Parameter => Parameter, 3408 Section => Section_Name.all); 3409 end if; 3410 end Do_Callback; 3411 3412 procedure For_Each_Simple 3413 is new For_Each_Simple_Switch (Simple_Callback); 3414 3415 --------------------- 3416 -- Simple_Callback -- 3417 --------------------- 3418 3419 procedure Simple_Callback 3420 (Simple_Switch : String; 3421 Separator : String; 3422 Parameter : String; 3423 Index : Integer) 3424 is 3425 pragma Unreferenced (Separator); 3426 begin 3427 Do_Callback (Switch => Simple_Switch, 3428 Parameter => Parameter, 3429 Index => Index); 3430 end Simple_Callback; 3431 3432 -- Start of processing for Getopt 3433 3434 begin 3435 -- Initialize sections 3436 3437 if Config.Sections = null then 3438 Config.Sections := new Argument_List'(1 .. 0 => null); 3439 end if; 3440 3441 Internal_Initialize_Option_Scan 3442 (Parser => Parser, 3443 Switch_Char => Parser.Switch_Character, 3444 Stop_At_First_Non_Switch => Parser.Stop_At_First, 3445 Section_Delimiters => Section_Delimiters (Config)); 3446 3447 Getopt_Switches := new String' 3448 (Get_Switches (Config, Parser.Switch_Character, Section_Name.all) 3449 & " h -help"); 3450 3451 -- Initialize output values for automatically handled switches 3452 3453 for S in Config.Switches'Range loop 3454 case Config.Switches (S).Typ is 3455 when Switch_Untyped => 3456 null; -- Nothing to do 3457 3458 when Switch_Boolean => 3459 Config.Switches (S).Boolean_Output.all := 3460 not Config.Switches (S).Boolean_Value; 3461 3462 when Switch_Integer => 3463 Config.Switches (S).Integer_Output.all := 3464 Config.Switches (S).Integer_Initial; 3465 3466 when Switch_String => 3467 if Config.Switches (S).String_Output.all = null then 3468 Config.Switches (S).String_Output.all := new String'(""); 3469 end if; 3470 end case; 3471 end loop; 3472 3473 -- For all sections, and all switches within those sections 3474 3475 loop 3476 C := Getopt (Switches => Getopt_Switches.all, 3477 Concatenate => Concatenate, 3478 Parser => Parser); 3479 3480 if C = '*' then 3481 -- Full_Switch already includes the leading '-' 3482 3483 Do_Callback (Switch => Full_Switch (Parser), 3484 Parameter => Parameter (Parser), 3485 Index => -1); 3486 3487 elsif C /= ASCII.NUL then 3488 if Full_Switch (Parser) = "h" 3489 or else 3490 Full_Switch (Parser) = "-help" 3491 then 3492 Display_Help (Config); 3493 raise Exit_From_Command_Line; 3494 end if; 3495 3496 -- Do switch expansion if needed 3497 3498 For_Each_Simple 3499 (Config, 3500 Section => Section_Name.all, 3501 Switch => Parser.Switch_Character & Full_Switch (Parser), 3502 Parameter => Parameter (Parser)); 3503 3504 else 3505 if Current_Section = -1 then 3506 Current_Section := Config.Sections'First; 3507 else 3508 Current_Section := Current_Section + 1; 3509 end if; 3510 3511 exit when Current_Section > Config.Sections'Last; 3512 3513 Section_Name := Config.Sections (Current_Section); 3514 Goto_Section (Section_Name.all, Parser); 3515 3516 Free (Getopt_Switches); 3517 Getopt_Switches := new String' 3518 (Get_Switches 3519 (Config, Parser.Switch_Character, Section_Name.all)); 3520 end if; 3521 end loop; 3522 3523 Free (Getopt_Switches); 3524 3525 exception 3526 when Invalid_Switch => 3527 Free (Getopt_Switches); 3528 3529 -- Message inspired by "ls" on Unix 3530 3531 Put_Line (Standard_Error, 3532 Base_Name (Ada.Command_Line.Command_Name) 3533 & ": unrecognized option '" 3534 & Full_Switch (Parser) 3535 & "'"); 3536 Put_Line (Standard_Error, 3537 "Try `" 3538 & Base_Name (Ada.Command_Line.Command_Name) 3539 & " --help` for more information."); 3540 3541 raise; 3542 3543 when others => 3544 Free (Getopt_Switches); 3545 raise; 3546 end Getopt; 3547 3548 ----------- 3549 -- Build -- 3550 ----------- 3551 3552 procedure Build 3553 (Line : in out Command_Line; 3554 Args : out GNAT.OS_Lib.Argument_List_Access; 3555 Expanded : Boolean := False; 3556 Switch_Char : Character := '-') 3557 is 3558 Iter : Command_Line_Iterator; 3559 Count : Natural := 0; 3560 3561 begin 3562 Start (Line, Iter, Expanded => Expanded); 3563 while Has_More (Iter) loop 3564 if Is_New_Section (Iter) then 3565 Count := Count + 1; 3566 end if; 3567 3568 Count := Count + 1; 3569 Next (Iter); 3570 end loop; 3571 3572 Args := new Argument_List (1 .. Count); 3573 Count := Args'First; 3574 3575 Start (Line, Iter, Expanded => Expanded); 3576 while Has_More (Iter) loop 3577 if Is_New_Section (Iter) then 3578 Args (Count) := new String'(Switch_Char & Current_Section (Iter)); 3579 Count := Count + 1; 3580 end if; 3581 3582 Args (Count) := new String'(Current_Switch (Iter) 3583 & Current_Separator (Iter) 3584 & Current_Parameter (Iter)); 3585 Count := Count + 1; 3586 Next (Iter); 3587 end loop; 3588 end Build; 3589 3590end GNAT.Command_Line; 3591