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