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