]> git.vpit.fr Git - perl/modules/Perl-Critic-Policy-Dynamic-NoIndirect.git/blob - lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
aab3ff6c7386c3dc050b9239793dfe410c543f7b
[perl/modules/Perl-Critic-Policy-Dynamic-NoIndirect.git] / lib / Perl / Critic / Policy / Dynamic / NoIndirect.pm
1 package Perl::Critic::Policy::Dynamic::NoIndirect;
2
3 use 5.008;
4
5 use strict;
6 use warnings;
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.05
15
16 =cut
17
18 our $VERSION = '0.05';
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 use base qw/Perl::Critic::DynamicPolicy/;
30
31 use Perl::Critic::Utils qw/:severities/;
32
33 sub default_severity { $SEVERITY_HIGH }
34 sub default_themes   { qw/dynamic maintenance/ }
35 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  my ($self, undef, $doc) = @_;
45
46  my ($src, $file);
47  if ($doc->isa('PPI::Document::File')) {
48   $file = $doc->filename;
49   open my $fh, '<', $file
50       or do { require Carp; Carp::confess("Can't open $file for reading: $!") };
51   $src = do { local $/; <$fh> };
52  } else {
53   $file = '(eval 0)';
54   $src  = $doc->serialize;
55  }
56
57  $file =~ s/(?<!\\)((\\\\)*)"/$1\\"/g;
58
59  my @errs;
60  my $hook = sub { push @errs, [ @_ ] };
61
62  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   local ($@, *_);
76   eval $wrapper; ## no critic
77   if (my $err = $@) {
78    require Carp;
79    Carp::croak("Couldn't compile the source wrapper: $err");
80   }
81  }
82
83  my @violations;
84
85  if (@errs) {
86   my %errs_tags;
87   for (@errs) {
88    my ($obj, $meth, $line) = @$_[0, 1, 3];
89    my $tag = join "\0", $line, $meth, $tag_obj->($obj);
90    push @{$errs_tags{$tag}}, [ $obj, $meth ];
91   }
92
93   $doc->find(sub {
94    my $elt = $_[1];
95    my $pos = $elt->location;
96    return 0 unless $pos;
97
98    my $tag = join "\0", $pos->[0], $elt, $tag_obj->($elt->snext_sibling);
99    if (my $errs = $errs_tags{$tag}) {
100     push @violations, do { my $e = pop @$errs; push @$e, $elt; $e };
101     delete $errs_tags{$tag} unless @$errs;
102     return 1 unless %errs_tags;
103    }
104
105    return 0;
106   });
107  }
108
109  return map {
110   my ($obj, $meth, $elt) = @$_;
111   $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"$obj\"";
112   $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 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