1use Test2::V0 -target => 'App::Yath::Options'; 2require App::Yath::Command; 3 4subtest sugar => sub { 5 package Test::Options::One; 6 use App::Yath::Options; 7 use Test2::V0 -target => 'App::Yath::Options'; 8 9 imported_ok(qw/post option options option_group include_options/); 10 11 like( 12 dies { $CLASS->import() }, 13 qr/Test::Options::One already has an 'options' method/, 14 "Cannot double-import" 15 ); 16 17 isa_ok(options(), [$CLASS], "options() returns an instance"); 18 19 my $line; 20 option_group {prefix => 'foo'}, sub { 21 option_group {category => 'uhg'}, sub { 22 $line = __LINE__; 23 option 'xxx' => (description => 'xxx'); 24 option 'a_foo' => (description => 'a foo'); 25 }; 26 option 'outer' => (description => 'outer'); 27 }; 28 29 is( 30 options()->all, 31 [ 32 { 33 type => 'b', 34 description => 'xxx', 35 field => 'xxx', 36 name => 'xxx', 37 prefix => 'foo', 38 title => 'xxx', 39 category => 'uhg', 40 trace => [__PACKAGE__, __FILE__, $line + 1], 41 }, 42 { 43 type => 'b', 44 description => 'a foo', 45 field => 'a_foo', 46 name => 'a-foo', 47 prefix => 'foo', 48 title => 'a_foo', 49 category => 'uhg', 50 trace => [__PACKAGE__, __FILE__, $line + 2], 51 }, 52 { 53 type => 'b', 54 description => 'outer', 55 field => 'outer', 56 name => 'outer', 57 prefix => 'foo', 58 title => 'outer', 59 category => 'NO CATEGORY - FIX ME', 60 trace => [__PACKAGE__, __FILE__, $line + 4], 61 }, 62 ], 63 "Added options, correct traces, prefix from group, nestable", 64 ); 65 66 like( 67 dies { option_group { builds => 'A::Fake::Module::Name' }, sub { 1 } }, 68 qr/Can't locate A.+Fake.+Module.+Name\.pm/, 69 "'builds' must be a valid module" 70 ); 71 72 post foo => sub { 1 }; 73 post bar => sub { 'app-a' }, sub { 2 }; 74 option_group {applicable => sub { 'app-b' } }, sub { post baz => sub { 3 } }; 75 76 my $posts = options->post_list; 77 like( 78 $posts, 79 [ 80 ['foo'], 81 ['bar'], 82 ['baz'], 83 ], 84 "All 3 posts were listed" 85 ); 86 is($posts->[0]->[1], undef, "No applicability check for foo"); 87 is($posts->[0]->[2]->(), 1, "Correct callback for foo"); 88 is($posts->[1]->[1]->(), 'app-a', "correct applicability check for bar"); 89 is($posts->[1]->[2]->(), 2, "Correct callback fo bar"); 90 is($posts->[2]->[1]->(), 'app-b', "correct applicability check for baz (from group)"); 91 is($posts->[2]->[2]->(), 3, "Correct callback fo baz"); 92 93 like( 94 dies { post foo => 1 }, 95 qr/You must provide a callback coderef/, 96 "Code is required" 97 ); 98 99 package Test::Options::Two; 100 use App::Yath::Options; 101 use Test2::V0 -target => 'App::Yath::Options'; 102 103 include_options 'Test::Options::One'; 104 105 is(options()->all(), Test::Options::One->options()->all(), "Included options"); 106}; 107 108subtest init => sub { 109 my $one = $CLASS->new(); 110 isa_ok($one, [$CLASS], "Created an instance"); 111 112 can_ok( 113 $one, 114 [qw{ 115 all lookup pre_list cmd_list post_list post_list_sorted settings args 116 command_class pending_pre pending_cmd pending_post included set_by_cli 117 }], 118 "Attributes" 119 ); 120 121 like( 122 $one, 123 { 124 all => [], 125 lookup => {}, 126 pre_list => [], 127 cmd_list => [], 128 post_list => [], 129 included => {}, 130 set_by_cli => {}, 131 }, 132 "Set defaults", 133 ); 134 135 isa_ok($one->settings, ['Test2::Harness::Settings'], "Generated a settings object by default"); 136}; 137 138subtest option => sub { 139 my $one = $CLASS->new(); 140 141 my $trace = [__PACKAGE__, __FILE__, __LINE__ + 1]; 142 my $opt = $one->option('foo', prefix => 'pre'); 143 isa_ok($opt, ['App::Yath::Option'], "Got an option instance"); 144 is($opt->trace, $trace, "Injected the correct trace"); 145 is($opt->title, 'foo', "Correct title"); 146 is($opt->prefix, 'pre', "Correct prefix"); 147 is($one->all, [exact_ref($opt)], "Added the option"); 148 is($one->cmd_list, [exact_ref($opt)], "Added the option for commands"); 149 is($one->lookup, {foo => exact_ref($opt)}, "Added option to the lookup"); 150}; 151 152subtest _option => sub { 153 my $one = $CLASS->new(); 154 155 my $trace = [__PACKAGE__, __FILE__, __LINE__ + 1]; 156 my $opt = $one->_option($trace, 'foo', prefix => 'pre'); 157 isa_ok($opt, ['App::Yath::Option'], "Got an option instance"); 158 is($opt->trace, $trace, "Used the correct trace"); 159 is($opt->title, 'foo', "Correct title"); 160 is($opt->prefix, 'pre', "Correct prefix"); 161 is($one->all, [exact_ref($opt)], "Added the option"); 162 is($one->cmd_list, [exact_ref($opt)], "Added the option for commands"); 163 is($one->lookup, {foo => exact_ref($opt)}, "Added option to the lookup"); 164}; 165 166subtest _parse_option_args => sub { 167 my $one = $CLASS->new(); 168 169 is( 170 {$one->_parse_option_args('foo')}, 171 {title => 'foo', type => undef}, 172 "Parse just title" 173 ); 174 175 is( 176 {$one->_parse_option_args('foo=b')}, 177 {title => 'foo', type => 'b'}, 178 "Parse title=type" 179 ); 180 181 is( 182 {$one->_parse_option_args('foo', 'b')}, 183 {title => 'foo', type => 'b'}, 184 "Parse title, type" 185 ); 186 187 is( 188 {$one->_parse_option_args('foo', type => 'b', other => 'yes')}, 189 {title => 'foo', type => 'b', other => 'yes'}, 190 "Parse title, %opts" 191 ); 192}; 193 194subtest _parse_option_caller => sub { 195 no warnings 'once'; 196 local *My::Caller::A::option_prefix = sub { 'MyPrefix' }; 197 my $one = $CLASS->new(); 198 199 is( 200 {$one->_parse_option_caller('My::Caller::A', {})}, 201 {prefix => 'myprefix'}, 202 "Found prefix from package, and lowercased it" 203 ); 204 205 is( 206 {$one->_parse_option_caller('FAKE', {prefix => 'MyPrefix'})}, 207 {prefix => 'myprefix'}, 208 "Found prefix from proto, and lowercased it" 209 ); 210 211 like( 212 dies { $one->_parse_option_caller('FAKE', {title => 'foo'}) }, 213 qr/Could not find an option prefix and option is not top-level \(foo\)/, 214 "Need a prefix" 215 ); 216 217 local @App::Yath::Command::fake::ISA = ('App::Yath::Command'); 218 local *App::Yath::Command::fake::name = sub { 'fake' }; 219 is( 220 {$one->_parse_option_caller('App::Yath::Command::fake')}, 221 {from_command => 'fake'}, 222 "Found command, prefix not required" 223 ); 224 225 is( 226 {$one->_parse_option_caller('App::Yath::Command::fake::Options::Foo')}, 227 {from_command => 'fake'}, 228 "Found command (options class for command), prefix not required" 229 ); 230 231 is( 232 {$one->_parse_option_caller('App::Yath')}, 233 {}, 234 "Special case, prefix not required for App::Yath namespace" 235 ); 236 237 is( 238 {$one->_parse_option_caller('App::Yath::Plugin::Foo')}, 239 {from_plugin => 'App::Yath::Plugin::Foo', prefix => 'foo'}, 240 "Automatic prefix for plugin" 241 ); 242 is( 243 {$one->_parse_option_caller('App::Yath::Plugin::Foo', {prefix => 'bar'})}, 244 {from_plugin => 'App::Yath::Plugin::Foo', prefix => 'bar'}, 245 "Can override automatic plugin prefix" 246 ); 247}; 248 249subtest include_option => sub { 250 my $one = $CLASS->new(); 251 252 like( 253 dies { $one->include_option(bless({title => 'foo', prefix => 'pre'}, 'App::Yath::Option')) }, 254 qr/Options must have a trace/, 255 "Need a trace" 256 ); 257 258 my $opt = App::Yath::Option->new(title => 'foo', prefix => 'foo'); 259 is($one->include_option($opt), exact_ref($opt), "Added, and returned the reference"); 260 261 like( 262 $one, 263 { 264 lookup => {foo => exact_ref($opt)}, 265 all => [exact_ref($opt)], 266 cmd_list => [exact_ref($opt)], 267 }, 268 "Added the option and indexed it" 269 ); 270}; 271 272subtest _index_option => sub { 273 my $one = $CLASS->new(); 274 my $opt1 = App::Yath::Option->new(title => 'foo', short => 'f', alt => ['fooo', 'fo'], prefix => 'foo'); 275 my $opt2 = App::Yath::Option->new(title => 'boo', short => 'b', alt => ['booo', 'bo'], prefix => 'foo'); 276 277 is($one->_index_option($opt1), 4, "indexed into 4 slots"); 278 is($one->_index_option($opt1), 0, "Double indexing the same opt does not explode, 0 slots"); 279 is( 280 $one->lookup, 281 { 282 f => exact_ref($opt1), 283 fo => exact_ref($opt1), 284 foo => exact_ref($opt1), 285 fooo => exact_ref($opt1), 286 }, 287 "Index has all 4 items", 288 ); 289 290 is($one->_index_option($opt2), 4, "indexed into 4 slots"); 291 is($one->_index_option($opt2), 0, "Double indexing the same opt does not explode, 0 slots"); 292 is( 293 $one->lookup, 294 { 295 f => exact_ref($opt1), 296 fo => exact_ref($opt1), 297 foo => exact_ref($opt1), 298 fooo => exact_ref($opt1), 299 b => exact_ref($opt2), 300 bo => exact_ref($opt2), 301 boo => exact_ref($opt2), 302 booo => exact_ref($opt2), 303 }, 304 "Index has all items", 305 ); 306 307 my $string = $opt1->trace_string; 308 like( 309 dies { $one->_index_option(App::Yath::Option->new(title => 'foo', prefix => 'foo')) }, 310 qr/Option 'foo' was already defined \(\Q$string\E\)/, 311 "Cannot add 2 opts with the same long flag" 312 ); 313 like( 314 dies { $one->_index_option(App::Yath::Option->new(title => 'xoo', alt => ['fo'], prefix => 'foo')) }, 315 qr/Option 'fo' was already defined \(\Q$string\E\)/, 316 "Cannot add 2 opts with the same long flag (alt)" 317 ); 318 like( 319 dies { $one->_index_option(App::Yath::Option->new(title => 'zoo', short => 'f', prefix => 'foo')) }, 320 qr/Option 'f' was already defined \(\Q$string\E\)/, 321 "Cannot add 2 opts with the same short flag" 322 ); 323}; 324 325subtest _list_option => sub { 326 my $one = $CLASS->new(); 327 my $opt1 = App::Yath::Option->new(title => 'foo', prefix => 'xxx'); 328 my $opt2 = App::Yath::Option->new(title => 'bar', prefix => 'xxx', pre_command => 1); 329 330 ok($one->_list_option($opt1), "listed option 1"); 331 ok($one->_list_option($opt2), "listed option 2"); 332 333 like( 334 $one, 335 { 336 cmd_list => [exact_ref($opt1)], 337 pre_list => [exact_ref($opt2)], 338 }, 339 "Added both options to the correct lists" 340 ); 341}; 342 343subtest include => sub { 344 my $one = $CLASS->new(post_list_sorted => 1); 345 346 like( 347 dies { $one->include() }, 348 qr/Include must be an instance of $CLASS, got undef/, 349 "Must specify what to include" 350 ); 351 352 like( 353 dies { $one->include('foo') }, 354 qr/Include must be an instance of $CLASS, got 'foo'/, 355 "String is not a valid include" 356 ); 357 358 like( 359 dies { $one->include($CLASS) }, 360 qr/Include must be an instance of $CLASS, got '$CLASS'/, 361 "Package is not a valid include" 362 ); 363 364 my $ref = []; 365 like( 366 dies { $one->include($ref) }, 367 qr/Include must be an instance of $CLASS, got '\Q$ref\E'/, 368 "A reference is not a valid include" 369 ); 370 371 bless $ref, 'XXX'; 372 like( 373 dies { $one->include($ref) }, 374 qr/Include must be an instance of $CLASS, got '\Q$ref\E'/, 375 "Must be an instance of $CLASS" 376 ); 377 378 my $two = $CLASS->new(); 379 my $opt1 = $two->option('foo', prefix => 'bar'); 380 my $opt2 = $two->option('baz', prefix => 'bar', pre_command => 1); 381 my $post = sub { 1 }; 382 $two->_post(1, undef, $post); 383 384 $one->include($two); 385 like( 386 $one, 387 { 388 post_list_sorted => F(), 389 post_list => [[1, undef, exact_ref($post)]], 390 cmd_list => [exact_ref($opt1)], 391 pre_list => [exact_ref($opt2)], 392 all => [exact_ref($opt1), exact_ref($opt2)], 393 lookup => {baz => exact_ref($opt2), foo => exact_ref($opt1)}, 394 }, 395 "Included options and post-callbacks from the second instance" 396 ); 397}; 398 399subtest include_from => sub { 400 my $one = $CLASS->new(post_list_sorted => 1); 401 402 my $two = $CLASS->new(); 403 my $opt1 = $two->option('foo', prefix => 'bar'); 404 my $opt2 = $two->option('baz', prefix => 'bar', pre_command => 1); 405 my $post = sub { 1 }; 406 $two->_post(1, undef, $post); 407 $two->included->{'fake'} = 2; 408 409 no warnings 'once'; 410 *Some::Fake::Package::options = sub { $two }; 411 412 $one->include_from('Some::Fake::Package'); 413 like( 414 $one, 415 { 416 post_list_sorted => F(), 417 post_list => [[1, undef, exact_ref($post)]], 418 cmd_list => [exact_ref($opt1)], 419 pre_list => [exact_ref($opt2)], 420 all => [exact_ref($opt1), exact_ref($opt2)], 421 lookup => {baz => exact_ref($opt2), foo => exact_ref($opt1)}, 422 included => {'fake' => T(), 'Some::Fake::Package' => T()}, 423 }, 424 "Included options and post-callbacks from the specified package" 425 ); 426 427 like( 428 dies { $one->include_from('Some::Other::Package') }, 429 qr/Can't locate Some.+Other.+Package\.pm in \@INC/, 430 "Must be a valid package" 431 ); 432}; 433 434subtest populate_pre_defaults => sub { 435 my $one = $CLASS->new(); 436 437 $one->option('noo', prefix => 'x', type => 's'); 438 $one->option('foo', prefix => 'x', pre_command => 1, type => 's'); 439 $one->option('bar', prefix => 'x', pre_command => 1, type => 'h'); 440 $one->option('baz', prefix => 'x', pre_command => 1, type => 's', default => 42); 441 $one->option('bat', prefix => 'x', pre_command => 1, type => 'm', default => sub { [42] }); 442 $one->option('ban', prefix => 'x', pre_command => 1, type => 'h', default => sub { {answer => 42} }); 443 $one->option('bag', prefix => 'x', pre_command => 1, type => 's', default => sub { }); 444 445 $one->populate_pre_defaults(); 446 447 is( 448 ${$one->settings->x}, 449 { 450 baz => 42, 451 bar => {}, 452 bat => [42], 453 ban => {answer => 42}, 454 455 # The field itself is vivified, but no value set, thus it is undef 456 # This prevents $settings->x->foo from exploding 457 foo => undef, 458 459 # Default returned an empty list, just vivify, maybe they know what 460 # they are doing? 461 bag => undef, 462 463 # Be explicit, this should NOT be populated, not even as undef 464 noo => DNE(), 465 }, 466 "Populated fields as expected", 467 ); 468}; 469 470subtest populate_cmd_defaults => sub { 471 my $one = $CLASS->new(); 472 473 $one->option('noo', prefix => 'x', pre_command => 1, type => 's'); 474 $one->option('foo', prefix => 'x', type => 's'); 475 $one->option('bar', prefix => 'x', type => 'h'); 476 $one->option('baz', prefix => 'x', type => 's', default => 42); 477 $one->option('bat', prefix => 'x', type => 'm', default => sub { [42] }); 478 $one->option('ban', prefix => 'x', type => 'h', default => sub { {answer => 42} }); 479 $one->option('bag', prefix => 'x', type => 's', default => sub { }); 480 481 like( 482 dies { $one->populate_cmd_defaults() }, 483 qr/The 'command_class' attribute has not yet been set/, 484 "Need to set command class first" 485 ); 486 487 push @App::Yath::Command::fake::ISA => 'App::Yath::Command'; 488 $one->set_command_class('App::Yath::Command::fake'); 489 $one->populate_cmd_defaults(); 490 491 is( 492 ${$one->settings->x}, 493 { 494 baz => 42, 495 bar => {}, 496 bat => [42], 497 ban => {answer => 42}, 498 499 # The field itself is vivified, but no value set, thus it is undef 500 # This prevents $settings->x->foo from exploding 501 foo => undef, 502 503 # Default returned an empty list, just vivify, maybe they know what 504 # they are doing? 505 bag => undef, 506 507 # We also process any remaining pre-command ops 508 noo => undef, 509 }, 510 "Populated fields as expected", 511 ); 512}; 513 514subtest set_args => sub { 515 my $one = $CLASS->new(); 516 517 ok(!$one->args, "No args yet"); 518 519 $one->set_args(['foo', 'bar']); 520 is($one->args, ['foo', 'bar'], "Set the args"); 521 522 like( 523 dies { $one->set_args(['a']) }, 524 qr/'args' has already been set/, 525 "Cannot set args a second time", 526 ); 527 528 is($one->args, ['foo', 'bar'], "Args did not change"); 529}; 530 531subtest _grab_opts => sub { 532 my $one = $CLASS->new(); 533 534 like( 535 dies { $one->_grab_opts() }, 536 qr/The opt_fetch callback is required/, 537 "Need opts" 538 ); 539 540 like( 541 dies { $one->_grab_opts(sub {[]}) }, 542 qr/The arg type is required/, 543 "Need arg type" 544 ); 545 546 like( 547 dies { $one->_grab_opts(sub {[]}, 'blah') }, 548 qr/The 'args' attribute has not yet been set/, 549 "Need args" 550 ); 551 552 $one = $CLASS->new; 553 my $opt1 = $one->option('foo', prefix => 'x', type => 'b', short => 'f'); 554 my $opt2 = $one->option('bar', prefix => 'x', type => 'b', alt => ['ba']); 555 my $opt3 = $one->option('baz', prefix => 'x', type => 's'); 556 my $opt4 = $one->option('bat', prefix => 'x', type => 'm'); 557 my $opt5 = $one->option('ban', prefix => 'x', type => 'd'); 558 559 $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '--', '--bat', 'NO']; 560 my @out = $one->_grab_opts('all', 'foo'); 561 562 is($one->args, ['xxx', 'blah', '--', '--bat', 'NO'], "Pulled out known args, stopped at --"); 563 is( 564 \@out, 565 [ 566 [exact_ref($opt1), 'handle', 1], 567 [exact_ref($opt2), 'handle', 1], 568 [exact_ref($opt3), 'handle', 'uhg'], 569 [exact_ref($opt4), 'handle', 'a'], 570 [exact_ref($opt1), 'handle_negation'], 571 [exact_ref($opt4), 'handle', 'b'], 572 [exact_ref($opt5), 'handle', 'y'], 573 [exact_ref($opt5), 'handle', 1], 574 ], 575 "Got actions to take" 576 ); 577 578 $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '::', '--bat', 'NO']; 579 @out = $one->_grab_opts('all', 'foo'); 580 581 is($one->args, ['xxx', 'blah', '::', '--bat', 'NO'], "Pulled out known args, stopped at ::"); 582 is( 583 \@out, 584 [ 585 [exact_ref($opt1), 'handle', 1], 586 [exact_ref($opt2), 'handle', 1], 587 [exact_ref($opt3), 'handle', 'uhg'], 588 [exact_ref($opt4), 'handle', 'a'], 589 [exact_ref($opt1), 'handle_negation'], 590 [exact_ref($opt4), 'handle', 'b'], 591 [exact_ref($opt5), 'handle', 'y'], 592 [exact_ref($opt5), 'handle', 1], 593 ], 594 "Got actions to take" 595 ); 596 597 $one->{args} = ['-f', '--ba', 'xxx', '--baz=uhg']; 598 like( 599 dies { $one->_grab_opts('all', 'foo', die_at_non_opt => 1) }, 600 qr/Invalid foo option: xxx/, 601 "Died at non-opt", 602 ); 603 604 $one->{args} = ['-f', '--ba', 'xxx', '--xyz', '--baz=uhg']; 605 like( 606 dies { $one->_grab_opts('all', 'foo') }, 607 qr/Invalid foo option: --xyz/, 608 "Died at invalid opt", 609 ); 610 611 $one->{args} = ['-f', '--ba', 'xxx', '--xyz', '--baz=uhg']; 612 @out = $one->_grab_opts('all', 'foo', passthrough => 1); 613 614 is($one->args, ['xxx', '--xyz'], "Pulled out known args"); 615 is( 616 \@out, 617 [ 618 [exact_ref($opt1), 'handle', 1], 619 [exact_ref($opt2), 'handle', 1], 620 [exact_ref($opt3), 'handle', 'uhg'], 621 ], 622 "Got actions to take" 623 ); 624}; 625 626subtest '*_command_opts' => sub { 627 my $set_def = 0; 628 my $control = mock $CLASS => ( 629 override => [ 630 populate_cmd_defaults => sub { $set_def++ }, 631 ], 632 ); 633 my $one = $CLASS->new(); 634 $one->set_command_class('App::Yath::Command'); 635 636 my $opt1 = $one->option('foo', prefix => 'x', type => 'b', short => 'f'); 637 my $opt2 = $one->option('bar', prefix => 'x', type => 'b', alt => ['ba']); 638 my $opt3 = $one->option('baz', prefix => 'x', type => 's'); 639 my $opt4 = $one->option('bat', prefix => 'x', type => 'm'); 640 my $opt5 = $one->option('ban', prefix => 'x', type => 'D'); 641 my $opt6 = $one->option('bag', prefix => 'x', type => 's', pre_command => 1); 642 643 $one->{args} = ['-f', '--ba', 'xxx', '--bag=yes', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', 'blah', '--', '--bat', 'NO']; 644 $one->grab_command_opts($one->all, 'foo'); 645 646 is($one->args, ['xxx', 'blah', '--', '--bat', 'NO'], "Pulled out known args, stopped at --"); 647 is( 648 $one->pending_cmd, 649 [ 650 [exact_ref($opt1), 'handle', 1], 651 [exact_ref($opt2), 'handle', 1], 652 [exact_ref($opt6), 'handle', 'yes'], 653 [exact_ref($opt3), 'handle', 'uhg'], 654 [exact_ref($opt4), 'handle', 'a'], 655 [exact_ref($opt1), 'handle_negation'], 656 [exact_ref($opt4), 'handle', 'b'], 657 [exact_ref($opt5), 'handle', 'y'], 658 [exact_ref($opt5), 'handle', 1], 659 ], 660 "Got actions to take, including pre-command options that were not processed yet" 661 ); 662 663 $one->process_command_opts; 664 665 is($one->pending_cmd, undef, "Nothing left to do"); 666 667 is( 668 ${$one->settings->x}, 669 { 670 foo => FDNE(), 671 bar => T(), 672 baz => 'uhg', 673 bat => ['a', 'b'], 674 ban => ['y', 1], 675 bag => 'yes', 676 }, 677 "Set the proper settings" 678 ); 679}; 680 681subtest '*_pre_command_opts' => sub { 682 my $set_def = 0; 683 my $control = mock $CLASS => ( 684 override => [ 685 populate_pre_defaults => sub { $set_def++ }, 686 ], 687 ); 688 my $one = $CLASS->new(); 689 690 my $opt1 = $one->option('foo', pre_command => 1, prefix => 'x', type => 'b', short => 'f'); 691 my $opt2 = $one->option('bar', pre_command => 1, prefix => 'x', type => 'b', alt => ['ba']); 692 my $opt3 = $one->option('baz', pre_command => 1, prefix => 'x', type => 's'); 693 my $opt4 = $one->option('bat', pre_command => 1, prefix => 'x', type => 'm'); 694 my $opt5 = $one->option('ban', pre_command => 1, prefix => 'x', type => 'D'); 695 my $opt6 = $one->option('bag', pre_command => 0, prefix => 'x', type => 'd'); 696 697 $one->{args} = ['-f', '--ba', '--baz=uhg', '--bat', 'a', '--no-foo', '--bat', 'b', '--ban=y', '--ban', '--bag=yes', 'xxx', 'blah', '--bat', 'NO']; 698 $one->grab_pre_command_opts($one->all, 'foo'); 699 700 is($one->args, ['--bag=yes', 'xxx', 'blah', '--bat', 'NO'], "Pulled out known args, stopped at non-opt"); 701 is( 702 $one->pending_pre, 703 [ 704 [exact_ref($opt1), 'handle', 1], 705 [exact_ref($opt2), 'handle', 1], 706 [exact_ref($opt3), 'handle', 'uhg'], 707 [exact_ref($opt4), 'handle', 'a'], 708 [exact_ref($opt1), 'handle_negation'], 709 [exact_ref($opt4), 'handle', 'b'], 710 [exact_ref($opt5), 'handle', 'y'], 711 [exact_ref($opt5), 'handle', 1], 712 ], 713 "Got actions to take, did not grab command options" 714 ); 715 716 $one->process_pre_command_opts; 717 718 is($one->pending_pre, undef, "Nothing left to do"); 719 720 is( 721 ${$one->settings->x}, 722 { 723 foo => FDNE(), 724 bar => T(), 725 baz => 'uhg', 726 bat => ['a', 'b'], 727 ban => ['y', 1], 728 bag => DNE(), 729 }, 730 "Set the proper settings" 731 ); 732}; 733 734subtest set_command_class => sub { 735 my $one = $CLASS->new(); 736 737 ok(!$one->command_class, "No command class yet"); 738 739 require App::Yath::Command::test; 740 my $cmd = bless {}, 'App::Yath::Command::test'; 741 $one->set_command_class($cmd); 742 is($one->command_class, 'App::Yath::Command::test', "Can set via a blessed command instance"); 743 744 like( 745 dies { $one->set_command_class() }, 746 qr/Command class has already been set/, 747 "Cannot change command class once set." 748 ); 749 750 ok($one->included->{'App::Yath::Command::test'}, "Included options from the command"); 751 752 $one = $CLASS->new(); 753 $one->set_command_class('App::Yath::Command::test'); 754 is($one->command_class, 'App::Yath::Command::test', "Can set via a class name"); 755 756 $one = $CLASS->new(); 757 like( 758 dies { $one->set_command_class('Test2::Harness::Util') }, 759 qr/Invalid command class: Test2::Harness::Util/, 760 "Must be a valid command class" 761 ); 762}; 763 764subtest post => sub { 765 my $one = $CLASS->new(post_list_sorted => 1); 766 767 my $sub = sub { 'foo' }; 768 $one->_post(undef, undef, $sub); 769 ok(!$one->post_list_sorted, "List is no longer considered sorted when we add an item"); 770 is($one->post_list, [[0, undef, exact_ref($sub)]], "Added item to post list"); 771 772 like( 773 dies { $one->process_option_post_actions }, 774 qr/The 'args' attribute has not yet been set/, 775 "Need args first" 776 ); 777 778 $one = $CLASS->new(); 779 $one->set_args(['foo']); 780}; 781 782done_testing; 783