Overview
| Comment: | natools-getopt_long_tests: test suite for getopt_long facilites |
|---|---|
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: |
f729f34843c2a025655ab126876207ea |
| User & Date: | nat on 2011-11-25 10:16:45 |
| Other Links: | manifest | tags |
Context
|
2011-11-25
| ||
| 10:17 | test_all: binary that runs all tests suites check-in: 422f985dc3 user: nat tags: trunk | |
| 10:16 | natools-getopt_long_tests: test suite for getopt_long facilites check-in: f729f34843 user: nat tags: trunk | |
| 10:06 | natools-getopt_long: native Ada implementation of getopt_long facilities check-in: 704e78d675 user: nat tags: trunk | |
Changes
Added natools-getopt_long_tests.adb version [bf7f31f3e7].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
------------------------------------------------------------------------------
-- Copyright (c) 2011, Natacha Porté --
-- --
-- Permission to use, copy, modify, and distribute this software for any --
-- purpose with or without fee is hereby granted, provided that the above --
-- copyright notice and this permission notice appear in all copies. --
-- --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. --
------------------------------------------------------------------------------
with Ada.Containers.Indefinite_Vectors;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Natools.Getopt_Long;
package body Natools.Getopt_Long_Tests is
package US renames Ada.Strings.Unbounded;
----------------------------------------
-- Dynamic command line argument list --
----------------------------------------
package String_Vectors is new Ada.Containers.Indefinite_Vectors
(Index_Type => Positive, Element_Type => String);
Command_Line : String_Vectors.Vector;
function Argument_Count return Natural;
function Argument (Number : Positive) return String;
function Argument_Count return Natural is
begin
return Natural (Command_Line.Length);
end Argument_Count;
function Argument (Number : Positive) return String is
begin
return Command_Line.Element (Number);
end Argument;
--------------------------------
-- Arguments used for testing --
--------------------------------
type Option_Id is
(Short_No_Arg, Short_No_Arg_2, Short_Opt_Arg, Short_Arg,
Long_No_Arg, Long_Opt_Arg, Long_Arg, Long_Ambiguous,
Mixed_No_Arg, Mixed_Opt_Arg, Mixed_Arg,
Command_Argument);
type Flag_Seen_Array is array (Option_Id) of Boolean;
type Flag_Argument_Array is array (Option_Id) of US.Unbounded_String;
package Getopt is new Natools.Getopt_Long (Option_Id);
Flag_Seen : Flag_Seen_Array;
Flag_Argument : Flag_Argument_Array;
Flag_Error : String_Vectors.Vector;
Separator : constant Character := ';';
procedure Callback (Id : Option_Id; Argument : String);
-- Process the given argument, by recording it as seen in Flag_Seen
-- and appending the argument to Flag_Argument.
procedure Dump (Report : in out NT.Reporter'Class);
-- Dump the current state (Flag_* variables) into the Report.
function Option_Definitions return Getopt.Option_Definitions;
-- Create the Option_Definitions object used for these tests.
procedure Reset_Flags;
-- Reset Flag_* variables for a new test.
procedure Callback (Id : Option_Id; Argument : String) is
begin
Flag_Seen (Id) := True;
US.Append (Flag_Argument (Id), Argument & Separator);
end Callback;
procedure Dump (Report : in out NT.Reporter'Class) is
procedure Process (Position : String_Vectors.Cursor);
function Seen_String (Seen : Boolean) return String;
procedure Process (Position : String_Vectors.Cursor) is
begin
Report.Info ("Error """ & String_Vectors.Element (Position) & '"');
end Process;
function Seen_String (Seen : Boolean) return String is
begin
if Seen then
return "Seen";
else
return "Not seen";
end if;
end Seen_String;
begin
Report.Info ("Flags:");
for Id in Option_Id loop
Report.Info (" " & Option_Id'Image (Id) & ": "
& Seen_String (Flag_Seen (Id)) & ", """
& US.To_String (Flag_Argument (Id)) & '"');
end loop;
Flag_Error.Iterate (Process'Access);
end Dump;
function Option_Definitions return Getopt.Option_Definitions is
begin
return OD : Getopt.Option_Definitions do
OD.Add_Option ('a', Getopt.No_Argument, Short_No_Arg);
OD.Add_Option ('q', Getopt.No_Argument, Short_No_Arg_2);
OD.Add_Option ('f', Getopt.Required_Argument, Short_Arg);
OD.Add_Option ('v', Getopt.Optional_Argument, Short_Opt_Arg);
OD.Add_Option ("aq", Getopt.No_Argument, Long_Ambiguous);
OD.Add_Option ("aquatic", Getopt.No_Argument, Long_No_Arg);
OD.Add_Option ("color", Getopt.Optional_Argument, Long_Opt_Arg);
OD.Add_Option ("input", Getopt.Required_Argument, Long_Arg);
OD.Add_Option ("execute", 'e', Getopt.Required_Argument, Mixed_Arg);
OD.Add_Option ("ignore-case", 'i', Getopt.No_Argument, Mixed_No_Arg);
OD.Add_Option ("write", 'w', Getopt.Optional_Argument, Mixed_Opt_Arg);
end return;
end Option_Definitions;
procedure Reset_Flags is
begin
for Id in Option_Id loop
Flag_Seen (Id) := False;
Flag_Argument (Id) := US.Null_Unbounded_String;
end loop;
Flag_Error.Clear;
end Reset_Flags;
----------------------------
-- Generic test procedure --
----------------------------
procedure Test
(Report : in out NT.Reporter'Class;
Name : String;
Expected_Seen : Flag_Seen_Array;
Expected_Argument : Flag_Argument_Array;
Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector;
Posixly_Correct : Boolean := True;
Long_Only : Boolean := False);
procedure Test
(Report : in out NT.Reporter'Class;
Name : String;
Expected_Seen : Flag_Seen_Array;
Expected_Argument : Flag_Argument_Array;
Expected_Error : String_Vectors.Vector := String_Vectors.Empty_Vector;
Posixly_Correct : Boolean := True;
Long_Only : Boolean := False)
is
use type String_Vectors.Vector;
Options : constant Getopt.Option_Definitions := Option_Definitions;
begin
Reset_Flags;
begin
Options.Process
(Top_Level_Argument => Command_Argument,
Callback => Callback'Access,
Posixly_Correct => Posixly_Correct,
Long_Only => Long_Only,
Argument_Count => Argument_Count'Access,
Argument => Argument'Access);
exception
when Error : Getopt.Option_Error =>
Flag_Error.Append (Ada.Exceptions.Exception_Message (Error));
end;
if Flag_Seen = Expected_Seen and
Flag_Argument = Expected_Argument and
Flag_Error = Expected_Error
then
Report.Item (Name, NT.Success);
else
Report.Item (Name, NT.Fail);
Dump (Report);
end if;
exception
when Error : others =>
Report.Report_Exception (Name, Error);
Dump (Report);
end Test;
---------------------------
-- Public test functions --
---------------------------
procedure All_Tests (Report : in out NT.Reporter'Class) is
begin
Test_Arguments (Report);
Test_Empty (Report);
Test_Error_Callbacks (Report);
Test_Everything (Report);
Test_Long (Report);
Test_Long_Only (Report);
Test_Long_Partial (Report);
Test_Long_Partial_Ambiguous (Report);
Test_Missing_Argument_Long (Report);
Test_Missing_Argument_Short (Report);
Test_Mixed_Arg (Report);
Test_Mixed_No_Arg (Report);
Test_Posixly_Correct (Report);
Test_Short_Argument (Report);
Test_Short_Compact (Report);
Test_Short_Expanded (Report);
Test_Unexpected_Argument (Report);
Test_Unknown_Long (Report);
Test_Unknown_Short (Report);
end All_Tests;
procedure Test_Arguments (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("Argument 1");
Command_Line.Append ("Argument 2");
Command_Line.Append ("Argument 3");
Test (Report, "Arguments without flag",
(Command_Argument => True,
others => False),
(Command_Argument
=> US.To_Unbounded_String ("Argument 1;Argument 2;Argument 3;"),
others => US.Null_Unbounded_String));
end Test_Arguments;
procedure Test_Empty (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Test (Report, "Empty command line",
(others => False),
(others => US.Null_Unbounded_String));
end Test_Empty;
procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class) is
procedure Local_Test
(Name : String;
Expected_Seen : Flag_Seen_Array;
Expected_Argument : Flag_Argument_Array;
Expected_Missing_Argument : Natural := 0;
Expected_Unexpected_Argument : Natural := 0;
Expected_Unknown_Long_Option : Natural := 0;
Expected_Unknown_Short_Option : Natural := 0);
procedure Missing_Argument (Id : Option_Id);
procedure Unexpected_Argument (Id : Option_Id; Arg : String);
procedure Unknown_Long_Option (Name : String);
procedure Unknown_Short_Option (Name : Character);
Missing_Argument_Nb, Unexpected_Argument_Nb,
Unknown_Long_Option_Nb, Unknown_Short_Option_Nb : Natural;
procedure Local_Test
(Name : String;
Expected_Seen : Flag_Seen_Array;
Expected_Argument : Flag_Argument_Array;
Expected_Missing_Argument : Natural := 0;
Expected_Unexpected_Argument : Natural := 0;
Expected_Unknown_Long_Option : Natural := 0;
Expected_Unknown_Short_Option : Natural := 0)
is
Options : constant Getopt.Option_Definitions := Option_Definitions;
begin
Reset_Flags;
Missing_Argument_Nb := 0;
Unexpected_Argument_Nb := 0;
Unknown_Long_Option_Nb := 0;
Unknown_Short_Option_Nb := 0;
Options.Process
(Top_Level_Argument => Command_Argument,
Callback => Callback'Access,
Missing_Argument => Missing_Argument'Access,
Unexpected_Argument => Unexpected_Argument'Access,
Unknown_Long_Option => Unknown_Long_Option'Access,
Unknown_Short_Option => Unknown_Short_Option'Access,
Argument_Count => Argument_Count'Access,
Argument => Argument'Access);
if Missing_Argument_Nb /= Expected_Missing_Argument or
Unexpected_Argument_Nb /= Expected_Unexpected_Argument or
Unknown_Long_Option_Nb /= Expected_Unknown_Long_Option or
Unknown_Short_Option_Nb /= Expected_Unknown_Short_Option
then
Report.Item (Name, NT.Fail);
if Missing_Argument_Nb /= Expected_Missing_Argument then
Report.Info ("Missing argument callback called"
& Natural'Image (Missing_Argument_Nb)
& " times, expected"
& Natural'Image (Expected_Missing_Argument));
end if;
if Unexpected_Argument_Nb /= Expected_Unexpected_Argument then
Report.Info ("Unexpected argument callback called"
& Natural'Image (Unexpected_Argument_Nb)
& " times, expected"
& Natural'Image (Expected_Unexpected_Argument));
end if;
if Unknown_Long_Option_Nb /= Expected_Unknown_Long_Option then
Report.Info ("Unknown long option callback called"
& Natural'Image (Unknown_Long_Option_Nb)
& " times, expected"
& Natural'Image (Expected_Unknown_Long_Option));
end if;
if Unknown_Short_Option_Nb /= Expected_Unknown_Short_Option then
Report.Info ("Unknown short option callback called"
& Natural'Image (Unknown_Short_Option_Nb)
& " times, expected"
& Natural'Image (Expected_Unknown_Short_Option));
end if;
elsif Flag_Seen /= Expected_Seen or
Flag_Argument /= Expected_Argument
then
Report.Item (Name, NT.Fail);
Dump (Report);
else
Report.Item (Name, NT.Success);
end if;
exception
when Error : others =>
Report.Report_Exception (Name, Error);
Dump (Report);
end Local_Test;
procedure Missing_Argument (Id : Option_Id) is
pragma Unreferenced (Id);
begin
Missing_Argument_Nb := Missing_Argument_Nb + 1;
end Missing_Argument;
procedure Unexpected_Argument (Id : Option_Id; Arg : String) is
pragma Unreferenced (Id, Arg);
begin
Unexpected_Argument_Nb := Unexpected_Argument_Nb + 1;
end Unexpected_Argument;
procedure Unknown_Long_Option (Name : String) is
pragma Unreferenced (Name);
begin
Unknown_Long_Option_Nb := Unknown_Long_Option_Nb + 1;
end Unknown_Long_Option;
procedure Unknown_Short_Option (Name : Character) is
pragma Unreferenced (Name);
begin
Unknown_Short_Option_Nb := Unknown_Short_Option_Nb + 1;
end Unknown_Short_Option;
begin
Report.Section ("Error-handling callbacks");
Command_Line.Clear;
Command_Line.Append ("-af");
Local_Test ("Missing argument for short option",
(Short_No_Arg => True, others => False),
(Short_No_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
Expected_Missing_Argument => 1);
Command_Line.Clear;
Command_Line.Append ("--color");
Command_Line.Append ("--input");
Local_Test ("Missing argument for long option",
(Long_Opt_Arg => True, others => False),
(Long_Opt_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
Expected_Missing_Argument => 1);
Command_Line.Clear;
Command_Line.Append ("--aquatic=extra");
Local_Test ("Unexpected argument",
(others => False),
(others => US.Null_Unbounded_String),
Expected_Unexpected_Argument => 1);
Command_Line.Clear;
Command_Line.Append ("-a");
Command_Line.Append ("--ignore-case=true");
Command_Line.Append ("--execute");
Command_Line.Append ("command");
Command_Line.Append ("file");
Local_Test ("Process continues after caught unexpected argument",
(Short_No_Arg | Mixed_Arg | Command_Argument => True,
others => False),
(Short_No_Arg => US.To_Unbounded_String (";"),
Mixed_Arg => US.To_Unbounded_String ("command;"),
Command_Argument => US.To_Unbounded_String ("file;"),
others => US.Null_Unbounded_String),
Expected_Unexpected_Argument => 1);
Command_Line.Clear;
Command_Line.Append ("-abqffoo");
Local_Test ("Unknown short option",
(Short_No_Arg | Short_No_Arg_2 | Short_Arg => True,
others => False),
(Short_No_Arg => US.To_Unbounded_String (";"),
Short_No_Arg_2 => US.To_Unbounded_String (";"),
Short_Arg => US.To_Unbounded_String ("foo;"),
others => US.Null_Unbounded_String),
Expected_Unknown_Short_Option => 1);
Command_Line.Clear;
Command_Line.Append ("--execute");
Command_Line.Append ("command");
Command_Line.Append ("--unknown=argument");
Command_Line.Append ("file");
Local_Test ("Unknown long option",
(Mixed_Arg | Command_Argument => True, others => False),
(Mixed_Arg => US.To_Unbounded_String ("command;"),
Command_Argument => US.To_Unbounded_String ("file;"),
others => US.Null_Unbounded_String),
Expected_Unknown_Long_Option => 1);
Command_Line.Clear;
Command_Line.Append ("--ignore-case");
Command_Line.Append ("-bffoo");
Command_Line.Append ("--aq=unexpected");
Command_Line.Append ("-ecommand");
Command_Line.Append ("--unknown");
Command_Line.Append ("--input");
Local_Test ("All errors simultaneously",
(Short_Arg | Mixed_No_Arg | Mixed_Arg => True,
others => False),
(Short_Arg => US.To_Unbounded_String ("foo;"),
Mixed_Arg => US.To_Unbounded_String ("command;"),
Mixed_No_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
Expected_Missing_Argument => 1,
Expected_Unexpected_Argument => 1,
Expected_Unknown_Long_Option => 1,
Expected_Unknown_Short_Option => 1);
Report.End_Section;
end Test_Error_Callbacks;
procedure Test_Everything (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--write=arg 1");
Command_Line.Append ("-awvfarg 2");
Command_Line.Append ("--aq");
Command_Line.Append ("-e");
Command_Line.Append ("arg 3");
Command_Line.Append ("--ignore-case");
Command_Line.Append ("--color=arg 4");
Command_Line.Append ("-iv");
Command_Line.Append ("--execute=arg 5");
Command_Line.Append ("--color");
Command_Line.Append ("--input");
Command_Line.Append ("arg 6");
Command_Line.Append ("arg 7");
Command_Line.Append ("arg 8");
Test (Report, "Everything together",
(Short_No_Arg_2 | Long_No_Arg => False, others => True),
(Short_No_Arg => US.To_Unbounded_String (";"),
Short_No_Arg_2 => US.Null_Unbounded_String,
Short_Arg => US.To_Unbounded_String ("arg 2;"),
Short_Opt_Arg => US.To_Unbounded_String (";;"),
Long_Ambiguous => US.To_Unbounded_String (";"),
Long_No_Arg => US.Null_Unbounded_String,
Long_Opt_Arg => US.To_Unbounded_String ("arg 4;;"),
Long_Arg => US.To_Unbounded_String ("arg 6;"),
Mixed_Arg => US.To_Unbounded_String ("arg 3;arg 5;"),
Mixed_No_Arg => US.To_Unbounded_String (";;"),
Mixed_Opt_Arg => US.To_Unbounded_String ("arg 1;;"),
Command_Argument => US.To_Unbounded_String ("arg 7;arg 8;")));
end Test_Everything;
procedure Test_Long (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--aquatic");
Command_Line.Append ("--input=i equal");
Command_Line.Append ("--color=c equal");
Command_Line.Append ("--input");
Command_Line.Append ("i space");
Command_Line.Append ("--color");
Command_Line.Append ("c space");
Command_Line.Append ("top level");
Test (Report, "Long flags",
(Long_No_Arg | Long_Opt_Arg | Long_Arg | Command_Argument => True,
others => False),
(Long_No_Arg => US.To_Unbounded_String (";"),
Long_Opt_Arg => US.To_Unbounded_String ("c equal;;"),
Long_Arg => US.To_Unbounded_String ("i equal;i space;"),
Command_Argument => US.To_Unbounded_String ("c space;top level;"),
others => US.Null_Unbounded_String));
end Test_Long;
procedure Test_Long_Only (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-aq");
-- Can be either 'a' and 'q' short flags or "aq" long flag, depending
-- on Long_Only parameter
-- Without Long_Only (default)
Test (Report, "Long_Only disabled (default)",
(Short_No_Arg | Short_No_Arg_2 => True, others => False),
(Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
Long_Only => False);
-- With Long_Only
Test (Report, "Long_Only enabled",
(Long_Ambiguous => True, others => False),
(Long_Ambiguous => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
Long_Only => True);
end Test_Long_Only;
procedure Test_Long_Partial (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--aqu");
Command_Line.Append ("--co=foo");
Command_Line.Append ("--in");
Command_Line.Append ("bar");
Test (Report, "Partial matches for long flags",
(Long_No_Arg | Long_Opt_Arg | Long_Arg => True, others => False),
(Long_No_Arg => US.To_Unbounded_String (";"),
Long_Opt_Arg => US.To_Unbounded_String ("foo;"),
Long_Arg => US.To_Unbounded_String ("bar;"),
others => US.Null_Unbounded_String));
end Test_Long_Partial;
procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--i");
-- partial match for both "input" and "ignore-case" long flags
Test (Report, "Ambiguous partial match for long flags",
(others => False),
(others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Unknown long option i", 1));
Command_Line.Clear;
Command_Line.Append ("--aq");
-- partial match for both "aq" and "aquatic" long flags
-- but exact match is preferred
Test (Report, "Ambiguous exact match for long flags",
(Long_Ambiguous => True, others => False),
(Long_Ambiguous => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String));
end Test_Long_Partial_Ambiguous;
procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--color");
Command_Line.Append ("--input");
Test (Report, "Missing argument for long option",
(Long_Opt_Arg => True, others => False),
(Long_Opt_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Missing argument to option input", 1));
end Test_Missing_Argument_Long;
procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-v");
Command_Line.Append ("-f");
Test (Report, "Missing argument for long option",
(Short_Opt_Arg => True, others => False),
(Short_Opt_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Missing argument to option f", 1));
end Test_Missing_Argument_Short;
procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-efoo");
Command_Line.Append ("-qe");
Command_Line.Append ("bar");
Command_Line.Append ("-aebaz");
Command_Line.Append ("--execute=long");
Test (Report, "Short and long options with arguments",
(Mixed_Arg | Short_No_Arg | Short_No_Arg_2 => True,
others => False),
(Mixed_Arg => US.To_Unbounded_String ("foo;bar;baz;long;"),
Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String));
end Test_Mixed_Arg;
procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-ai");
Command_Line.Append ("--ignore-case");
Test (Report, "Short and long options without arguments",
(Mixed_No_Arg | Short_No_Arg => True, others => False),
(Mixed_No_Arg => US.To_Unbounded_String (";;"),
Short_No_Arg => US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String));
end Test_Mixed_No_Arg;
procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-a");
Command_Line.Append ("top level");
Command_Line.Append ("-q");
-- Posixly_Correct defines whether this "-q" is a top-level argument
-- or a short flag
-- With the flag
Test (Report, "Posixly correct behavior",
(Short_No_Arg | Command_Argument => True,
others => False),
(Short_No_Arg => US.To_Unbounded_String (";"),
Command_Argument => US.To_Unbounded_String ("top level;-q;"),
others => US.Null_Unbounded_String),
Posixly_Correct => True);
-- Without the flag
Test (Report, "GNU (posixly incorrect) behavior",
(Short_No_Arg | Short_No_Arg_2 | Command_Argument => True,
others => False),
(Short_No_Arg | Short_No_Arg_2 => US.To_Unbounded_String (";"),
Command_Argument => US.To_Unbounded_String ("top level;"),
others => US.Null_Unbounded_String),
Posixly_Correct => False);
end Test_Posixly_Correct;
procedure Test_Short_Argument (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-faq");
-- "aq" is argument for 'f' short flag, not 'a' and 'q' short flags
Command_Line.Append ("-f");
Command_Line.Append ("-a");
-- "-a" is argument for 'f' short flag, not 'a' short flag
Command_Line.Append ("-v");
Command_Line.Append ("bar");
-- "bar" is top level argument, because optional argument for short
-- flags are never set
Test (Report, "Arguments to short flags",
(Short_Arg | Short_Opt_Arg | Command_Argument => True,
others => False),
(Short_Arg => US.To_Unbounded_String ("aq;-a;"),
Short_Opt_Arg => US.To_Unbounded_String (";"),
Command_Argument => US.To_Unbounded_String ("bar;"),
others => US.Null_Unbounded_String));
end Test_Short_Argument;
procedure Test_Short_Compact (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-avq");
-- "q" is not argument to 'v' short flag, but a short flag itself
Test (Report, "Argumentless compact short flags",
(Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True,
others => False),
(Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg =>
US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String));
end Test_Short_Compact;
procedure Test_Short_Expanded (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-a");
Command_Line.Append ("-v");
Command_Line.Append ("-q");
Test (Report, "Argumentless expanded short flags",
(Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg => True,
others => False),
(Short_No_Arg | Short_No_Arg_2 | Short_Opt_Arg =>
US.To_Unbounded_String (";"),
others => US.Null_Unbounded_String));
end Test_Short_Expanded;
procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--color=foo");
Command_Line.Append ("--aq=bar");
Test (Report, "Unexpected argument to long option",
(Long_Opt_Arg => True, others => False),
(Long_Opt_Arg => US.To_Unbounded_String ("foo;"),
others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Unexpected argument ""bar"" to aq", 1));
end Test_Unexpected_Argument;
procedure Test_Unknown_Long (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("--long-flag");
Test (Report, "Unknown long flag",
(others => False), (others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Unknown long option long-flag", 1));
end Test_Unknown_Long;
procedure Test_Unknown_Short (Report : in out NT.Reporter'Class) is
begin
Command_Line.Clear;
Command_Line.Append ("-g");
Test (Report, "Unknown short flag",
(others => False), (others => US.Null_Unbounded_String),
String_Vectors.To_Vector ("Unknown short option g", 1));
end Test_Unknown_Short;
end Natools.Getopt_Long_Tests;
|
Added natools-getopt_long_tests.ads version [3c1350bbcb].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | ------------------------------------------------------------------------------ -- Copyright (c) 2011, Natacha Porté -- -- -- -- Permission to use, copy, modify, and distribute this software for any -- -- purpose with or without fee is hereby granted, provided that the above -- -- copyright notice and this permission notice appear in all copies. -- -- -- -- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- -- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- -- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- -- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- -- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- -- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- -- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- Natools.Getopt_Long_Tests is a test suite for Natools.Getopt_Long -- -- command-line argument processing facilities. -- ------------------------------------------------------------------------------ with Natools.Tests; package Natools.Getopt_Long_Tests is pragma Preelaborate (Getopt_Long_Tests); package NT renames Natools.Tests; procedure All_Tests (Report : in out NT.Reporter'Class); procedure Test_Arguments (Report : in out NT.Reporter'Class); procedure Test_Empty (Report : in out NT.Reporter'Class); procedure Test_Error_Callbacks (Report : in out NT.Reporter'Class); procedure Test_Everything (Report : in out NT.Reporter'Class); procedure Test_Long (Report : in out NT.Reporter'Class); procedure Test_Long_Only (Report : in out NT.Reporter'Class); procedure Test_Long_Partial (Report : in out NT.Reporter'Class); procedure Test_Long_Partial_Ambiguous (Report : in out NT.Reporter'Class); procedure Test_Missing_Argument_Long (Report : in out NT.Reporter'Class); procedure Test_Missing_Argument_Short (Report : in out NT.Reporter'Class); procedure Test_Mixed_Arg (Report : in out NT.Reporter'Class); procedure Test_Mixed_No_Arg (Report : in out NT.Reporter'Class); procedure Test_Posixly_Correct (Report : in out NT.Reporter'Class); procedure Test_Short_Argument (Report : in out NT.Reporter'Class); procedure Test_Short_Compact (Report : in out NT.Reporter'Class); procedure Test_Short_Expanded (Report : in out NT.Reporter'Class); procedure Test_Unexpected_Argument (Report : in out NT.Reporter'Class); procedure Test_Unknown_Long (Report : in out NT.Reporter'Class); procedure Test_Unknown_Short (Report : in out NT.Reporter'Class); end Natools.Getopt_Long_Tests; |