File Coverage

blib/lib/MooseX/App/Plugin/MutexGroup/Meta/Class.pm
Criterion Covered Total %
statement 6 6 100.0
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 8 8 100.0


line stmt bran cond sub pod time code
1             # ============================================================================
2             package MooseX::App::Plugin::MutexGroup::Meta::Class;
3             # ============================================================================
4              
5 3     3   2081 use Moose::Role;
  3         5  
  3         17  
6 3     3   11006 use namespace::autoclean;
  3         4  
  3         35  
7              
8             around 'command_check_attributes' => sub {
9             my ( $orig, $self, $command_meta, $errors, $params ) = @_;
10             $command_meta ||= $self;
11              
12             my %mutex_groups;
13             foreach my $attribute (
14             $self->command_usage_attributes( $command_meta, 'all' ) ) {
15             push @{ $mutex_groups{ $attribute->mutexgroup } }, $attribute
16             if $attribute->can('mutexgroup')
17             && defined $attribute->mutexgroup;
18             }
19              
20             foreach my $options ( values %mutex_groups ) {
21             my @initialized_options =
22             grep { defined $params->{ $_->name } }
23             @$options;
24              
25             unless ( scalar @initialized_options == 1 ) {
26             my $error_msg;
27              
28             if (scalar @initialized_options == 0) {
29             my $last = pop @$options;
30             $error_msg = "Either ".
31             join(",", map { $_->cmd_name_primary } @$options).
32             " or ".
33             $last->cmd_name_primary.
34             " must be specified";
35             } else {
36             my @list = map { $_->cmd_name_primary } @initialized_options;
37             my $last = pop(@list);
38              
39             $error_msg = "Options ".
40             join(",",@list).
41             " and ".
42             $last.
43             " are mutally exclusive";
44             }
45              
46             push @$errors,
47             $self->command_message(
48             header => $error_msg,
49             type => "error",
50             );
51             }
52             }
53              
54             return $self->$orig( $command_meta, $errors, $params );
55             };
56              
57             1;