| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package YA::CLI::ActionRole; | 
| 2 |  |  |  |  |  |  | our $VERSION = '0.004'; | 
| 3 | 2 |  |  | 2 |  | 27001 | use Moo::Role; | 
|  | 2 |  |  |  |  | 6 |  | 
|  | 2 |  |  |  |  | 11 |  | 
| 4 | 2 |  |  | 2 |  | 911 | use namespace::autoclean; | 
|  | 2 |  |  |  |  | 16 |  | 
|  | 2 |  |  |  |  | 16 |  | 
| 5 |  |  |  |  |  |  |  | 
| 6 |  |  |  |  |  |  | # ABSTRACT: Action handler role | 
| 7 |  |  |  |  |  |  |  | 
| 8 | 2 |  |  | 2 |  | 237 | use YA::CLI::Usage; | 
|  | 2 |  |  |  |  | 6 |  | 
|  | 2 |  |  |  |  | 74 |  | 
| 9 | 2 |  |  | 2 |  | 9 | use Getopt::Long; | 
|  | 2 |  |  |  |  | 4 |  | 
|  | 2 |  |  |  |  | 41 |  | 
| 10 | 2 |  |  | 2 |  | 399 | use List::Util qw(none any); | 
|  | 2 |  |  |  |  | 4 |  | 
|  | 2 |  |  |  |  | 1487 |  | 
| 11 |  |  |  |  |  |  |  | 
| 12 |  |  |  |  |  |  | requires qw( | 
| 13 |  |  |  |  |  |  | action | 
| 14 |  |  |  |  |  |  | run | 
| 15 |  |  |  |  |  |  | ); | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | has _cli_args => ( | 
| 18 |  |  |  |  |  |  | is        => 'ro', | 
| 19 |  |  |  |  |  |  | predicate => '_has_cli_args', | 
| 20 |  |  |  |  |  |  | writer    => '_set_cli_args', | 
| 21 |  |  |  |  |  |  | init_args => undef, | 
| 22 |  |  |  |  |  |  | default   => sub { {} }, | 
| 23 |  |  |  |  |  |  | ); | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | sub cli_options { | 
| 26 | 3 |  |  | 3 | 1 | 8 | return; | 
| 27 |  |  |  |  |  |  | } | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | sub usage_pod { | 
| 30 | 3 |  |  | 3 | 1 | 8 | return; | 
| 31 |  |  |  |  |  |  | } | 
| 32 |  |  |  |  |  |  |  | 
| 33 |  |  |  |  |  |  | sub BUILD { | 
| 34 | 7 |  |  | 7 | 0 | 39 | my ($self, $args) = @_; | 
| 35 |  |  |  |  |  |  |  | 
| 36 | 7 |  |  |  |  | 24 | foreach (keys %$args) { | 
| 37 | 4 | 100 |  |  |  | 29 | delete $args->{$_} if $self->can($_); | 
| 38 |  |  |  |  |  |  | } | 
| 39 | 7 | 100 |  |  |  | 57 | $self->_set_cli_args($args) if %$args; | 
| 40 |  |  |  |  |  |  | } | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  | sub new_from_args { | 
| 43 | 7 |  |  | 7 | 1 | 17 | my ($class, $args) = @_; | 
| 44 | 7 |  |  |  |  | 34 | return $class->new($class->get_opts($args)); | 
| 45 |  |  |  |  |  |  | } | 
| 46 |  |  |  |  |  |  |  | 
| 47 |  |  |  |  |  |  | sub get_opts { | 
| 48 | 7 |  |  | 7 | 1 | 12 | my ($class, $args) = @_; | 
| 49 |  |  |  |  |  |  |  | 
| 50 | 7 |  |  |  |  | 26 | my $p = Getopt::Long::Parser->new( | 
| 51 |  |  |  |  |  |  | config => [qw(no_auto_abbrev) ] | 
| 52 |  |  |  |  |  |  | ); | 
| 53 |  |  |  |  |  |  |  | 
| 54 | 7 |  |  |  |  | 662 | my %cli_args; | 
| 55 | 7 |  |  |  |  | 20 | $p->getoptionsfromarray($args, \%cli_args, $class->cli_options); | 
| 56 | 7 |  |  |  |  | 1780 | return %cli_args; | 
| 57 |  |  |  |  |  |  | } | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  | sub has_action { | 
| 60 | 30 |  |  | 30 | 1 | 50 | my $self = shift; | 
| 61 | 30 |  |  |  |  | 38 | my $action  = shift; | 
| 62 | 30 |  |  |  |  | 45 | my $subaction = shift; | 
| 63 |  |  |  |  |  |  |  | 
| 64 | 30 | 100 |  | 30 |  | 110 | return if none { $action eq $_ } $self->action; | 
|  | 30 |  |  |  |  | 182 |  | 
| 65 |  |  |  |  |  |  |  | 
| 66 | 17 | 100 |  |  |  | 114 | if ($self->can('subaction')) { | 
| 67 | 4 | 50 |  |  |  | 9 | return 0 unless defined $subaction; | 
| 68 | 4 |  |  | 4 |  | 13 | return any { $subaction eq $_ } $self->subaction; | 
|  | 4 |  |  |  |  | 45 |  | 
| 69 |  |  |  |  |  |  | } | 
| 70 | 13 | 100 |  |  |  | 70 | return defined $subaction ? 0 : 1; | 
| 71 |  |  |  |  |  |  | } | 
| 72 |  |  |  |  |  |  |  | 
| 73 |  |  |  |  |  |  | sub as_help { | 
| 74 | 9 |  |  | 9 | 1 | 30 | my ($self, $rc, $message) = @_; | 
| 75 |  |  |  |  |  |  |  | 
| 76 | 9 | 100 | 100 |  |  | 63 | return YA::CLI::Usage->new( | 
| 77 |  |  |  |  |  |  | rc => ($rc // 0), | 
| 78 |  |  |  |  |  |  | $message ? (message  => $message) : (), | 
| 79 |  |  |  |  |  |  | $self->_get_podfile_for_usage, | 
| 80 |  |  |  |  |  |  | ); | 
| 81 |  |  |  |  |  |  | } | 
| 82 |  |  |  |  |  |  |  | 
| 83 |  |  |  |  |  |  | sub as_manpage { | 
| 84 | 2 |  |  | 2 | 1 | 3 | my ($self) = @_; | 
| 85 |  |  |  |  |  |  |  | 
| 86 | 2 |  |  |  |  | 5 | return YA::CLI::Usage->new( | 
| 87 |  |  |  |  |  |  | rc      => 0, | 
| 88 |  |  |  |  |  |  | verbose => 2, | 
| 89 |  |  |  |  |  |  | $self->_get_podfile_for_usage, | 
| 90 |  |  |  |  |  |  | ); | 
| 91 |  |  |  |  |  |  | } | 
| 92 |  |  |  |  |  |  |  | 
| 93 |  |  |  |  |  |  |  | 
| 94 |  |  |  |  |  |  | sub _get_podfile_for_usage { | 
| 95 | 11 |  |  | 11 |  | 20 | my $self = shift; | 
| 96 | 11 |  |  |  |  | 27 | my $podfile; | 
| 97 | 11 | 100 |  |  |  | 31 | if (my $pod = $self->usage_pod) { | 
| 98 | 2 | 50 |  |  |  | 12 | $podfile = $pod == 1? $self : $pod; | 
| 99 |  |  |  |  |  |  | } | 
| 100 | 11 | 100 |  |  |  | 251 | return $podfile ? ( pod_file => $podfile ) : (); | 
| 101 |  |  |  |  |  |  | } | 
| 102 |  |  |  |  |  |  |  | 
| 103 |  |  |  |  |  |  | 1; | 
| 104 |  |  |  |  |  |  |  | 
| 105 |  |  |  |  |  |  | __END__ |