File Coverage

blib/lib/Perl/Critic/Policy/Community/MultidimensionalArrayEmulation.pm
Criterion Covered Total %
statement 46 47 97.8
branch 22 24 91.6
condition 43 54 79.6
subroutine 12 13 92.3
pod 4 5 80.0
total 127 143 88.8


line stmt bran cond sub pod time code
1             package Perl::Critic::Policy::Community::MultidimensionalArrayEmulation;
2              
3 1     1   474 use strict;
  1         3  
  1         31  
4 1     1   5 use warnings;
  1         3  
  1         31  
5              
6 1     1   6 use Perl::Critic::Utils qw(:severities :classification :ppi);
  1         2  
  1         75  
7 1     1   419 use parent 'Perl::Critic::Policy';
  1         4  
  1         6  
8              
9 1     1   60 use List::Util 'any';
  1         2  
  1         102  
10              
11             our $VERSION = 'v1.0.1';
12              
13 1     1   9 use constant DESC => 'Use of multidimensional array emulation in hash subscript';
  1         3  
  1         93  
14 1     1   8 use constant EXPL => 'A list in a hash subscript used with the $ sigil triggers Perl 4 multidimensional array emulation. Nest structures using references instead.';
  1         2  
  1         651  
15              
16 4     4 0 20220 sub supported_parameters { () }
17 13     13 1 152 sub default_severity { $SEVERITY_LOW }
18 0     0 1 0 sub default_themes { 'community' }
19 4     4 1 87103 sub applies_to { 'PPI::Structure::Subscript' }
20              
21             sub violates {
22 34     34 1 3311 my ($self, $elem) = @_;
23 34 100 66     105 return () unless $elem->complete and $elem->braces eq '{}';
24            
25 30         560 my @contents = $elem->schildren;
26 30 50 33     400 @contents = $contents[0]->schildren if @contents == 1 and $contents[0]->isa('PPI::Statement::Expression');
27            
28             # check for function call with no parentheses; following args won't trigger MAE
29 30 100 100     440 if (@contents > 1 and $contents[0]->isa('PPI::Token::Word') and !$contents[1]->isa('PPI::Structure::List')
      100        
      66        
      100        
30             and !($contents[1]->isa('PPI::Token::Operator') and ($contents[1] eq ',' or $contents[1] eq '=>'))) {
31 1         5 return ();
32             }
33            
34             # check if contains top level , or multi-word qw
35             return () unless any {
36 51 100 66 51   383 ($_->isa('PPI::Token::Operator') and ($_ eq ',' or $_ eq '=>')) or
      100        
      100        
37             ($_->isa('PPI::Token::QuoteLike::Words') and (my @words = $_->literal) > 1)
38 29 100       252 } @contents;
39            
40             # check if it's a postderef slice
41 21         639 my $prev = $elem->sprevious_sibling;
42 21 50 66     631 return () if $prev and $prev->isa('PPI::Token::Cast') and ($prev eq '@' or $prev eq '%');
      66        
      66        
43            
44             # check if it's a slice
45 19         44 my ($cast, $found_symbol);
46 19         34 $prev = $elem;
47 19         49 while ($prev = $prev->sprevious_sibling) {
48 34 100 100     798 last if $found_symbol and !$prev->isa('PPI::Token::Cast');
49 33 100 66     173 if ($prev->isa('PPI::Token::Symbol')) {
    100          
    100          
50 12         42 $cast = $prev->raw_type;
51 12         95 $found_symbol = 1;
52             } elsif ($prev->isa('PPI::Structure::Block')) {
53 5         21 $found_symbol = 1;
54             } elsif ($found_symbol and $prev->isa('PPI::Token::Cast')) {
55 8         27 $cast = $prev;
56             } else {
57 8 100 66     46 last unless $prev->isa('PPI::Structure::Subscript')
      66        
58             or ($prev->isa('PPI::Token::Operator') and $prev eq '->');
59             }
60             }
61 19 100 100     380 return () if $cast and ($cast eq '@' or $cast eq '%');
      100        
62            
63 13         128 return $self->violation(DESC, EXPL, $elem);
64             }
65              
66             1;
67              
68             =head1 NAME
69              
70             Perl::Critic::Policy::Community::MultidimensionalArrayEmulation - Don't use
71             multidimensional array emulation
72              
73             =head1 DESCRIPTION
74              
75             When used with the C<@> or C<%> sigils, a list in a hash subscript (C<{}>) will
76             access multiple elements of the hash as a slice. With the C<$> sigil however,
77             it accesses the single element at the key defined by joining the list with the
78             subscript separator C<$;>. This feature is known as
79             L<perldata/"Multi-dimensional array emulation"> and provided a way to emulate
80             a multidimensional structure before Perl 5 introduced references. Perl now
81             supports true multidimensional structures, so this feature is now unnecessary
82             in most cases.
83              
84             $foo{$x,$y,$z} # not ok
85             $foo{qw(a b c)} # not ok
86             $foo{$x}{$y}{$z} # ok
87             @foo{$x,$y,$z} # ok
88              
89             =head1 AFFILIATION
90              
91             This policy is part of L<Perl::Critic::Community>.
92              
93             =head1 CONFIGURATION
94              
95             This policy is not configurable except for the standard options.
96              
97             =head1 AUTHOR
98              
99             Dan Book, C<dbook@cpan.org>
100              
101             =head1 COPYRIGHT AND LICENSE
102              
103             Copyright 2015, Dan Book.
104              
105             This library is free software; you may redistribute it and/or modify it under
106             the terms of the Artistic License version 2.0.
107              
108             =head1 SEE ALSO
109              
110             L<Perl::Critic>