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  @errs = sort { $a->[3] <=> $b->[3] } @errs;
  75
  76  my @violations;
  77
  78  if (@errs) {
  79   my ($err, $obj, $meth, $line);
  80
  81   $doc->find(sub {
  82    unless ($err) {
  83     return 1 unless @errs;
  84     $err = shift @errs;
  85     ($obj, $meth, $line) = @$err[0, 1, 3];
  86     $line -= $offset;
  87    }
  88
  89    my $elt = $_[1];
  90    my $pos = $elt->location;
  91
  92    if ($pos and $pos->[0] == $line and $elt eq $meth
  93                                    and $elt->snext_sibling eq $obj) {
  94     push @violations, [ $obj, $meth, $elt ];
  95     undef $err;
  96    }
  97
  98    return 0;
  99   });
 100  }
 101
 102  return map {
 103   my ($obj, $meth, $elt) = @$_;
 104   $self->violation(
 105    "Indirect call of method \"$meth\" on object \"$obj\"",
 106    "You really wanted $obj\->$meth",
 107    $elt,
 108   );
 109  } @violations;
 110 }
 111
 112 =head1 DEPENDENCIES
 113
 114 L<perl> 5.8, L<Carp>.
 115
 116 L<Perl::Critic>, L<Perl::Critic::Dynamic>.
 117
 118 L<indirect>.
 119
 120 =head1 AUTHOR
 121
 122 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 123
 124 You can contact me by mail or on C<irc.perl.org> (vincent).
 125
 126 =head1 BUGS
 127
 128 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>.
 129 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 130
 131 =head1 SUPPORT
 132
 133 You can find documentation for this module with the perldoc command.
 134
 135     perldoc Perl::Critic::Policy::Dynamic::NoIndirect
 136
 137 =head1 COPYRIGHT & LICENSE
 138
 139 Copyright 2009 Vincent Pit, all rights reserved.
 140
 141 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 142
 143 =cut
 144
 145 1; # End of Perl::Critic::Policy::Dynamic::NoIndirect