diff --git a/cpanfile b/cpanfile index eb260cb..018e54d 100644 --- a/cpanfile +++ b/cpanfile @@ -7,5 +7,6 @@ requires 'Path::Tiny'; on 'test' => sub { requires 'Test::More' => 1; requires 'Test::Lib'; + requires 'Test::Fatal'; requires 'Capture::Tiny'; }; diff --git a/lib/CLI/Osprey.pm b/lib/CLI/Osprey.pm index 0830885..8b36a0d 100644 --- a/lib/CLI/Osprey.pm +++ b/lib/CLI/Osprey.pm @@ -8,7 +8,7 @@ use warnings; use Carp 'croak'; use Module::Runtime 'use_module'; -use Scalar::Util qw(reftype); +use Scalar::Util qw(reftype blessed); use Moo::Role qw(); # only want class methods, not setting up a role @@ -84,6 +84,16 @@ sub import { my $option = sub { my ($name, %attributes) = @_; + + if ( $attributes{inherit} + && !defined $attributes{default} + && !defined $attributes{builder} + && $attributes{is} ne 'lazy' ) + { + $attributes{builder} = _inherited_option_builder( $target, $name ); + $attributes{lazy} = 1; + } + $has->($name => _non_option_attributes(%attributes)); $options_data->{$name} = _option_attributes($name, %attributes); $options_data->{$name}{added_order} = ++$added_order; @@ -148,6 +158,40 @@ sub _option_attributes { return $ret; } +sub _inherited_option_builder { + my ($target, $name) = @_; + + sub { + my $parent = $_[0]->{parent_command}; + return unless defined $parent; + + my $mth = $parent->can($name); + if (!defined $mth) { + my @path; + + # we can get the class of the parent (sub)command, + # but we want the actual command name. For that + # we need $parent->parent->_osprey_subcommands. + while (defined $parent) { + unshift @path, { reverse $parent->_osprey_subcommands }->{$target}; + $target = blessed $parent; + last if !defined $parent->{parent_command}; + $parent = $parent->{parent_command}; + } + unshift @path, $parent->invoked_as; + + my $subcommand = pop @path; + my $command = join(' / ', @path); + + require Carp; + Carp::croak( + qq[parent '$command' of '$subcommand' does not have a '--$name' option\n], + ); + } + $mth->($parent); + } +} + 1; __END__ @@ -419,6 +463,17 @@ Default: B. A C option will be recognized, but not listed in automatically generated documentation. +=head2 inherit + +Default: B. + +An inherited option's default value is the value of the parent +command's or sub-command's option of the same name. This attribute is +ignored if the C or C attributes are set (either +explicitly or implicitly). If the option has not been set and the +parent command or sub-command does not have a similarly named option, +an exception will be thrown when the option's value is first accessed. + =head2 negatable Default: B. diff --git a/t/inherit.t b/t/inherit.t new file mode 100644 index 0000000..de4844f --- /dev/null +++ b/t/inherit.t @@ -0,0 +1,323 @@ +#! perl + +use Test::More; +use Test::Fatal; + +use Path::Tiny; + +package CommonOptions { + + use Moo::Role; + + use CLI::Osprey; + + option inherit_no_default => ( + is => 'ro', + format => 's', + inherit => 1, + ); + + option inherit_default => ( + is => 'ro', + format => 's', + inherit => 1, + ); + + option not_inherited => ( + is => 'ro', + format => 's', + ); + +} + +package Cmd { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + + has '+inherit_default' => ( is => 'ro', default => 'default value' ); + + subcommand sc1 => 'SC1'; + subcommand sc1_1 => 'SC1_1'; + subcommand sc1_2 => 'SC1_2'; +} + +package SC1 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + option falsely_inherited => ( + is => 'ro', + format => 's', + inherit => 1, + ); + + + subcommand sc2 => 'SC2'; +} + + +package SC2 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + option falsely_inherited => ( + is => 'ro', + format => 's', + inherit => 1, + ); + +} + +package SC1_1 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + subcommand sc2_1 => 'SC2_1'; +} + + +package SC2_1 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + option falsely_inherited => ( + is => 'ro', + format => 's', + inherit => 1, + ); +} + +package SC1_2 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + subcommand sc2_2 => 'SC2_2'; +} + + +package SC2_2 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + subcommand sc3_2 => 'SC3_2'; + +} + +package SC3_2 { + + use Moo; + + use CLI::Osprey; + + with 'CommonOptions'; + + option falsely_inherited => ( + is => 'ro', + format => 's', + inherit => 1, + ); +} + + +sub test_attrs { + + my ( $title, $ARGV, %expected ) = @_; + + local @ARGV = @$ARGV; + my $cmd = Cmd->new_with_options; + + subtest $title => sub { + + while ( my ( $option, $value ) = each %expected ) { + is( $cmd->$option, $value, "correct value for $option" ); + } + + }; +} + + +subtest 'inherited' => sub { + + subtest 'command' => sub { + + test_attrs( + 'no values specified', + [], + inherit_no_default => undef, + inherit_default => 'default value', + not_inherited => undef + ); + + + test_attrs( + 'values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar ) + ], + inherit_no_default => 'foo', + inherit_default => 'goo', + not_inherited => 'bar', + ); + + }; + + subtest 'first level sub-command' => sub { + + test_attrs( + 'no values specified', + [qw( sc1 )], + inherit_no_default => undef, + inherit_default => 'default value', + not_inherited => undef + ); + + test_attrs( + 'command values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar sc1 ) + ], + inherit_no_default => 'foo', + inherit_default => 'goo', + not_inherited => undef, + ); + + + test_attrs( + 'command & sub-command values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar + sc1 + --inherit_no_default=foo1 --inherit_default=goo1 --not_inherited=bar1 + ) + ], + inherit_no_default => 'foo1', + inherit_default => 'goo1', + not_inherited => 'bar1', + ); + + }; + + subtest 'second level sub-command' => sub { + + test_attrs( + 'no values specified', + [qw( sc1 sc2 )], + inherit_no_default => undef, + inherit_default => 'default value', + not_inherited => undef + ); + + test_attrs( + 'command values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar sc1 sc2 ) + ], + inherit_no_default => 'foo', + inherit_default => 'goo', + not_inherited => undef, + ); + + + test_attrs( + 'command & sub-command values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar + sc1 + --inherit_no_default=foo1 --inherit_default=goo1 --not_inherited=bar1 + sc2 + ) + ], + inherit_no_default => 'foo1', + inherit_default => 'goo1', + not_inherited => undef, + ); + + + test_attrs( + 'command & sub-command & sub-sub-command values specified', + [ + qw( --inherit_no_default=foo --inherit_default=goo --not_inherited=bar + sc1 + --inherit_no_default=foo1 --inherit_default=goo1 --not_inherited=bar1 + sc2 + --inherit_no_default=foo2 --inherit_default=goo2 --not_inherited=bar2 + ) + ], + inherit_no_default => 'foo2', + inherit_default => 'goo2', + not_inherited => 'bar2', + ); + + }; +}; + +subtest 'falsely inherited' => sub { + + subtest 'first level subcommand' => sub { + + local @ARGV = ( qw[ sc1 ] ); + my $cmd = Cmd->new_with_options; + + like( + exception { $cmd->falsely_inherited }, + qr/'inherit.t' of 'sc1'/, + 'throws correctly' + ); + }; + + subtest 'second level subcommand' => sub { + + local @ARGV = ( qw[ sc1_1 sc2_1 ] ); + my $cmd = Cmd->new_with_options; + + like( + exception { $cmd->falsely_inherited }, + qr{'inherit.t / sc1_1' of 'sc2_1'}, + 'throws correctly' + ); + }; + + subtest 'third level subcommand' => sub { + + local @ARGV = ( qw[ sc1_2 sc2_2 sc3_2 ] ); + my $cmd = Cmd->new_with_options; + + like( + exception { $cmd->falsely_inherited }, + qr{'inherit.t / sc1_2 / sc2_2' of 'sc3_2'}, + 'throws correctly' + ); + }; + +}; + +done_testing;