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; |