X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FPerl%2FCritic%2FPolicy%2FDynamic%2FNoIndirect.pm;h=4d4c4d2d6343e99bc562bd25fe8c4f18d22038d8;hb=0e4837000c33bd7c179a6b22f442f0c63432f8c0;hp=aa4a03aed94b034333bf88b401e01bf1b2491a1e;hpb=ba8eb2c0e9b3b9a75dc7fd128e722b1a0eef8b75;p=perl%2Fmodules%2FPerl-Critic-Policy-Dynamic-NoIndirect.git

diff --git a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
index aa4a03a..4d4c4d2 100644
--- a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
+++ b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
@@ -11,11 +11,11 @@ Perl::Critic::Policy::Dynamic::NoIndirect - Perl::Critic policy against indirect
 
 =head1 VERSION
 
-Version 0.02
+Version 0.04
 
 =cut
 
-our $VERSION = '0.02';
+our $VERSION = '0.04';
 
 =head1 DESCRIPTION
 
@@ -34,22 +34,29 @@ sub default_severity { $SEVERITY_HIGH }
 sub default_themes   { qw/dynamic maintenance/ }
 sub applies_to       { 'PPI::Document' }
 
+my $tag_obj = sub {
+ my $obj = '' . $_[0];
+ $obj = '{' if $obj =~ /^\s*\{/;
+ $obj;
+};
+
 sub violates_dynamic {
  my ($self, undef, $doc) = @_;
 
- my $src;
-
+ my ($src, $file);
  if ($doc->isa('PPI::Document::File')) {
-  my $file = $doc->filename;
+  $file = $doc->filename;
   open my $fh, '<', $file
       or do { require Carp; Carp::confess("Can't open $file for reading: $!") };
   $src = do { local $/; <$fh> };
  } else {
-  $src = $doc->serialize;
+  $file = '(eval 0)';
+  $src  = $doc->serialize;
  }
 
+ $file =~ s/(?<!\\)((\\\\)*)"/$1\\"/g;
+
  my @errs;
- my $offset  = 6;
  my $wrapper = <<" WRAPPER";
  {
   return;
@@ -57,6 +64,7 @@ sub violates_dynamic {
   no indirect hook => sub { push \@errs, [ \@_ ] };
   {
    ;
+#line 1 "$file"
    $src
   }
  }
@@ -71,28 +79,26 @@ sub violates_dynamic {
   }
  }
 
- @errs = sort { $a->[3] <=> $b->[3] } @errs;
-
  my @violations;
 
  if (@errs) {
-  my ($err, $obj, $meth, $line);
+  my %errs_tags;
+  for (@errs) {
+   my ($obj, $meth, $line) = @$_[0, 1, 3];
+   my $tag = join "\0", $line, $meth, $tag_obj->($obj);
+   push @{$errs_tags{$tag}}, [ $obj, $meth ];
+  }
 
   $doc->find(sub {
-   unless ($err) {
-    return 1 unless @errs;
-    $err = shift @errs;
-    ($obj, $meth, $line) = @$err[0, 1, 3];
-    $line -= $offset;
-   }
-
    my $elt = $_[1];
    my $pos = $elt->location;
+   return 0 unless $pos;
 
-   if ($pos and $pos->[0] == $line and $elt eq $meth
-                                   and $elt->snext_sibling eq $obj) {
-    push @violations, [ $obj, $meth, $elt ];
-    undef $err;
+   my $tag = join "\0", $pos->[0], $elt, $tag_obj->($elt->snext_sibling);
+   if (my $errs = $errs_tags{$tag}) {
+    push @violations, do { my $e = pop @$errs; push @$e, $elt; $e };
+    delete $errs_tags{$tag} unless @$errs;
+    return 1 unless %errs_tags;
    }
 
    return 0;
@@ -101,14 +107,23 @@ sub violates_dynamic {
 
  return map {
   my ($obj, $meth, $elt) = @$_;
+  $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"$obj\"";
   $self->violation(
-   "Indirect call of method \"$meth\" on object \"$obj\"",
+   "Indirect call of method \"$meth\" on $obj",
    "You really wanted $obj\->$meth",
    $elt,
   );
  } @violations;
 }
 
+=head1 CAVEATS
+
+The uses of the L<indirect> pragma inside the audited code take precedence over this policy.
+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 => ... >>.
+Occurrences of C<no indirect> won't be a problem.
+
+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).
+
 =head1 DEPENDENCIES
 
 L<perl> 5.8, L<Carp>.
@@ -117,6 +132,13 @@ L<Perl::Critic>, L<Perl::Critic::Dynamic>.
 
 L<indirect>.
 
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Objects::ProhibitIndirectSyntax> is a L<Perl::Critic> policy that statically checks for indirect constructs.
+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.
+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).
+But you don't need to actually compile (or run, as it's more or less the same thing) the code.
+
 =head1 AUTHOR
 
 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
@@ -136,7 +158,7 @@ You can find documentation for this module with the perldoc command.
 
 =head1 COPYRIGHT & LICENSE
 
-Copyright 2009 Vincent Pit, all rights reserved.
+Copyright 2009,2010 Vincent Pit, all rights reserved.
 
 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.