line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perl::Critic::Policy::Dynamic::NoIndirect; |
2
|
|
|
|
|
|
|
|
3
|
30
|
|
|
30
|
|
7474467
|
use 5.008; |
|
30
|
|
|
|
|
148
|
|
|
30
|
|
|
|
|
1279
|
|
4
|
|
|
|
|
|
|
|
5
|
30
|
|
|
30
|
|
179
|
use strict; |
|
30
|
|
|
|
|
59
|
|
|
30
|
|
|
|
|
938
|
|
6
|
30
|
|
|
30
|
|
149
|
use warnings; |
|
30
|
|
|
|
|
64
|
|
|
30
|
|
|
|
|
1569
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
=head1 NAME |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
Perl::Critic::Policy::Dynamic::NoIndirect - Perl::Critic policy against indirect method calls. |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
=head1 VERSION |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
Version 0.06 |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
=cut |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our $VERSION = '0.06'; |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
=head1 DESCRIPTION |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
This L<Perl::Critic> dynamic policy reports any use of indirect object syntax with a C<'stern'> severity. |
23
|
|
|
|
|
|
|
It's listed under the C<'dynamic'> and C<'maintenance'> themes. |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
Since it wraps around L<indirect>, it needs to compile the audited code and as such is implemented as a subclass of L<Perl::Critic::DynamicPolicy>. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=cut |
28
|
|
|
|
|
|
|
|
29
|
30
|
|
|
30
|
|
149
|
use base qw<Perl::Critic::DynamicPolicy>; |
|
30
|
|
|
|
|
60
|
|
|
30
|
|
|
|
|
30364
|
|
30
|
|
|
|
|
|
|
|
31
|
30
|
|
|
30
|
|
1915609
|
use Perl::Critic::Utils qw<:severities>; |
|
30
|
|
|
|
|
62
|
|
|
30
|
|
|
|
|
2249
|
|
32
|
|
|
|
|
|
|
|
33
|
43
|
|
|
43
|
1
|
1896
|
sub default_severity { $SEVERITY_HIGH } |
34
|
0
|
|
|
0
|
1
|
0
|
sub default_themes { qw<dynamic maintenance> } |
35
|
434
|
|
|
434
|
1
|
356049269
|
sub applies_to { 'PPI::Document' } |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $tag_obj = sub { |
38
|
|
|
|
|
|
|
my $obj = '' . $_[0]; |
39
|
|
|
|
|
|
|
$obj = '{' if $obj =~ /^\s*\{/; |
40
|
|
|
|
|
|
|
$obj; |
41
|
|
|
|
|
|
|
}; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub violates_dynamic { |
44
|
28
|
|
|
28
|
1
|
117210
|
my ($self, undef, $doc) = @_; |
45
|
|
|
|
|
|
|
|
46
|
28
|
|
|
|
|
1724
|
my ($src, $file); |
47
|
28
|
50
|
|
|
|
2830
|
if ($doc->isa('PPI::Document::File')) { |
48
|
0
|
|
|
|
|
0
|
$file = $doc->filename; |
49
|
|
|
|
|
|
|
open my $fh, '<', $file |
50
|
0
|
0
|
|
|
|
0
|
or do { require Carp; Carp::confess("Can't open $file for reading: $!") }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
51
|
0
|
|
|
|
|
0
|
$src = do { local $/; <$fh> }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
52
|
|
|
|
|
|
|
} else { |
53
|
28
|
|
|
|
|
12656
|
$file = '(eval 0)'; |
54
|
28
|
|
|
|
|
3082
|
$src = $doc->serialize; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
28
|
|
|
|
|
35713
|
$file =~ s/(?<!\\)((\\\\)*)"/$1\\"/g; |
58
|
|
|
|
|
|
|
|
59
|
28
|
|
|
|
|
133
|
my @errs; |
60
|
28
|
|
|
43
|
|
1879
|
my $hook = sub { push @errs, [ @_ ] }; |
|
43
|
|
|
|
|
6147
|
|
61
|
|
|
|
|
|
|
|
62
|
28
|
|
|
|
|
887
|
my $wrapper = <<" WRAPPER"; |
63
|
|
|
|
|
|
|
return; |
64
|
|
|
|
|
|
|
package main; |
65
|
|
|
|
|
|
|
no strict; |
66
|
|
|
|
|
|
|
no warnings; |
67
|
|
|
|
|
|
|
no indirect hook => \$hook; |
68
|
|
|
|
|
|
|
do { |
69
|
|
|
|
|
|
|
#line 1 "$file" |
70
|
|
|
|
|
|
|
$src |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
WRAPPER |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
{ |
75
|
28
|
|
|
|
|
308
|
local ($@, *_); |
|
28
|
|
|
|
|
908
|
|
76
|
28
|
|
|
28
|
|
24126
|
eval $wrapper; ## no critic |
|
28
|
|
|
28
|
|
1323
|
|
|
28
|
|
|
28
|
|
266
|
|
|
28
|
|
|
|
|
6070
|
|
|
28
|
|
|
|
|
423
|
|
|
28
|
|
|
|
|
310
|
|
|
28
|
|
|
|
|
8595
|
|
|
28
|
|
|
|
|
59614
|
|
|
28
|
|
|
|
|
82481
|
|
|
28
|
|
|
|
|
529
|
|
77
|
28
|
50
|
|
|
|
662
|
if (my $err = $@) { |
78
|
0
|
|
|
|
|
0
|
require Carp; |
79
|
0
|
|
|
|
|
0
|
Carp::croak("Couldn't compile the source wrapper: $err"); |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
28
|
|
|
|
|
257
|
my @violations; |
84
|
|
|
|
|
|
|
|
85
|
28
|
100
|
|
|
|
612
|
if (@errs) { |
86
|
25
|
|
|
|
|
338
|
my %errs_tags; |
87
|
25
|
|
|
|
|
241
|
for (@errs) { |
88
|
43
|
|
|
|
|
381
|
my ($obj, $meth, $line) = @$_[0, 1, 3]; |
89
|
43
|
|
|
|
|
502
|
my $tag = join "\0", $line, $meth, $tag_obj->($obj); |
90
|
43
|
|
|
|
|
90
|
push @{$errs_tags{$tag}}, [ $obj, $meth ]; |
|
43
|
|
|
|
|
529
|
|
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
$doc->find(sub { |
94
|
532
|
|
|
532
|
|
11107
|
my $elt = $_[1]; |
95
|
532
|
|
|
|
|
5683
|
my $pos = $elt->location; |
96
|
532
|
50
|
|
|
|
16193
|
return 0 unless $pos; |
97
|
|
|
|
|
|
|
|
98
|
532
|
|
|
|
|
5784
|
my $tag = join "\0", $pos->[0], $elt, $tag_obj->($elt->snext_sibling); |
99
|
532
|
100
|
|
|
|
6915
|
if (my $errs = $errs_tags{$tag}) { |
100
|
43
|
|
|
|
|
210
|
push @violations, do { my $e = pop @$errs; push @$e, $elt; $e }; |
|
43
|
|
|
|
|
265
|
|
|
43
|
|
|
|
|
103
|
|
|
43
|
|
|
|
|
252
|
|
101
|
43
|
100
|
|
|
|
349
|
delete $errs_tags{$tag} unless @$errs; |
102
|
43
|
100
|
|
|
|
519
|
return 1 unless %errs_tags; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
507
|
|
|
|
|
2317
|
return 0; |
106
|
25
|
|
|
|
|
856
|
}); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
43
|
|
|
|
|
15012
|
return map { |
110
|
28
|
|
|
|
|
1130
|
my ($obj, $meth, $elt) = @$_; |
111
|
43
|
100
|
|
|
|
502
|
$obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"$obj\""; |
112
|
43
|
|
|
|
|
1962
|
$self->violation( |
113
|
|
|
|
|
|
|
"Indirect call of method \"$meth\" on $obj", |
114
|
|
|
|
|
|
|
"You really wanted $obj\->$meth", |
115
|
|
|
|
|
|
|
$elt, |
116
|
|
|
|
|
|
|
); |
117
|
|
|
|
|
|
|
} @violations; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=head1 CAVEATS |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
The uses of the L<indirect> pragma inside the audited code take precedence over this policy. |
123
|
|
|
|
|
|
|
Hence no violations will be reported for indirect method calls that are located inside the lexical scope of C<use indirect> or C<< no indirect hook => ... >>. |
124
|
|
|
|
|
|
|
Occurrences of C<no indirect> won't be a problem. |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Since the reports generated by L<indirect> are remapped to the corresponding L<PPI::Element> objects, the order in which the violations are returned is different from the order given by L<indirect> : the former is the document order (top to bottom, left to right) while the latter is the optree order (arguments before function calls). |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
L<perl> 5.8, L<Carp>. |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
L<Perl::Critic>, L<Perl::Critic::Dynamic>. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
L<indirect> 0.20. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=head1 SEE ALSO |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
L<Perl::Critic::Policy::Objects::ProhibitIndirectSyntax> is a L<Perl::Critic> policy that statically checks for indirect constructs. |
139
|
|
|
|
|
|
|
But to be static it has to be very restricted : you have to manually specify which subroutine names are methods for which the indirect form should be forbidden. |
140
|
|
|
|
|
|
|
This can lead to false positives (a subroutine with the name you gave is defined in the current scope) and negatives (indirect constructs for methods you didn't specify). |
141
|
|
|
|
|
|
|
But you don't need to actually compile (or run, as it's more or less the same thing) the code. |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
=head1 AUTHOR |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
You can contact me by mail or on C<irc.perl.org> (vincent). |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
=head1 BUGS |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
Please report any bugs or feature requests to C<bug-perl-critic-policy-dynamic-noindirect at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Perl-Critic-Policy-Dynamic-NoIndirect>. |
152
|
|
|
|
|
|
|
I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=head1 SUPPORT |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
perldoc Perl::Critic::Policy::Dynamic::NoIndirect |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
Copyright 2009,2010,2011 Vincent Pit, all rights reserved. |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
=cut |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
1; # End of Perl::Critic::Policy::Dynamic::NoIndirect |