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 auditted 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>.
 134
 135 =head1 AUTHOR
 136
 137 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 138
 139 You can contact me by mail or on C<irc.perl.org> (vincent).
 140
 141 =head1 BUGS
 142
 143 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>.
 144 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 145
 146 =head1 SUPPORT
 147
 148 You can find documentation for this module with the perldoc command.
 149
 150     perldoc Perl::Critic::Policy::Dynamic::NoIndirect
 151
 152 =head1 COPYRIGHT & LICENSE
 153
 154 Copyright 2009 Vincent Pit, all rights reserved.
 155
 156 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 157
 158 =cut
 159
 160 1; # End of Perl::Critic::Policy::Dynamic::NoIndirect