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