File Coverage

blib/lib/YA/CLI/ActionRole.pm
Criterion Covered Total %
statement 47 47 100.0
branch 18 20 90.0
condition 2 2 100.0
subroutine 16 16 100.0
pod 7 8 87.5
total 90 93 96.7


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__