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.04
  15
  16 =cut
  17
  18 our $VERSION = '0.04';
  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 $wrapper = <<" WRAPPER";
  61  {
  62   return;
  63   package main;
  64   no indirect hook => sub { push \@errs, [ \@_ ] };
  65   {
  66    ;
  67 #line 1 "$file"
  68    $src
  69   }
  70  }
  71  WRAPPER
  72
  73  {
  74   local ($@, *_);
  75   eval $wrapper; ## no critic
  76   if ($@) {
  77    require Carp;
  78    Carp::confess("Couldn't compile the source wrapper: $@");
  79   }
  80  }
  81
  82  my @violations;
  83
  84  if (@errs) {
  85   my %errs_tags;
  86   for (@errs) {
  87    my ($obj, $meth, $line) = @$_[0, 1, 3];
  88    my $tag = join "\0", $line, $meth, $tag_obj->($obj);
  89    push @{$errs_tags{$tag}}, [ $obj, $meth ];
  90   }
  91
  92   $doc->find(sub {
  93    my $elt = $_[1];
  94    my $pos = $elt->location;
  95    return 0 unless $pos;
  96
  97    my $tag = join "\0", $pos->[0], $elt, $tag_obj->($elt->snext_sibling);
  98    if (my $errs = $errs_tags{$tag}) {
  99     push @violations, do { my $e = pop @$errs; push @$e, $elt; $e };
 100     delete $errs_tags{$tag} unless @$errs;
 101     return 1 unless %errs_tags;
 102    }
 103
 104    return 0;
 105   });
 106  }
 107
 108  return map {
 109   my ($obj, $meth, $elt) = @$_;
 110   $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"$obj\"";
 111   $self->violation(
 112    "Indirect call of method \"$meth\" on $obj",
 113    "You really wanted $obj\->$meth",
 114    $elt,
 115   );
 116  } @violations;
 117 }
 118
 119 =head1 CAVEATS
 120
 121 The uses of the L<indirect> pragma inside the audited code take precedence over this policy.
 122 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 => ... >>.
 123 Occurrences of C<no indirect> won't be a problem.
 124
 125 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).
 126
 127 =head1 DEPENDENCIES
 128
 129 L<perl> 5.8, L<Carp>.
 130
 131 L<Perl::Critic>, L<Perl::Critic::Dynamic>.
 132
 133 L<indirect> 0.20.
 134
 135 =head1 SEE ALSO
 136
 137 L<Perl::Critic::Policy::Objects::ProhibitIndirectSyntax> is a L<Perl::Critic> policy that statically checks for indirect constructs.
 138 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.
 139 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).
 140 But you don't need to actually compile (or run, as it's more or less the same thing) the code.
 141
 142 =head1 AUTHOR
 143
 144 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 145
 146 You can contact me by mail or on C<irc.perl.org> (vincent).
 147
 148 =head1 BUGS
 149
 150 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>.
 151 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 152
 153 =head1 SUPPORT
 154
 155 You can find documentation for this module with the perldoc command.
 156
 157     perldoc Perl::Critic::Policy::Dynamic::NoIndirect
 158
 159 =head1 COPYRIGHT & LICENSE
 160
 161 Copyright 2009,2010 Vincent Pit, all rights reserved.
 162
 163 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 164
 165 =cut
 166
 167 1; # End of Perl::Critic::Policy::Dynamic::NoIndirect