Remove trailing whitespace

[perl/modules/Perl-Critic-Policy-Dynamic-NoIndirect.git] / lib / Perl / Critic / Policy / Dynamic / NoIndirect.pm

diff --git a/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm b/lib/Perl/Critic/Policy/Dynamic/NoIndirect.pm
index 11b9b5c6fe8ba5bc28f08c3a6d51bcd080d5d784..a727d0b1471fae40756e6c7a3f05cfda0a09d6b6 100644 (file)
--- 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
 
 
 =head1 VERSION
 

-Version 0.03
+Version 0.06

 
 =cut
 
 
 =cut
 

-our $VERSION = '0.03';
+our $VERSION = '0.06';

 
 =head1 DESCRIPTION
 
 
 =head1 DESCRIPTION
 


@@ -26,48 +26,57 @@ Since it wraps around L<indirect>, it needs to compile the audited code and as s
 
 =cut
 
 
 =cut
 

-use base qw/Perl::Critic::DynamicPolicy/;
+use base qw<Perl::Critic::DynamicPolicy>;

 
 

-use Perl::Critic::Utils qw/:severities/;
+use Perl::Critic::Utils qw<:severities>;

 
 sub default_severity { $SEVERITY_HIGH }
 
 sub default_severity { $SEVERITY_HIGH }

-sub default_themes   { qw/dynamic maintenance/ }
+sub default_themes   { qw<dynamic maintenance> }

 sub applies_to       { 'PPI::Document' }
 
 sub applies_to       { 'PPI::Document' }
 

+my $tag_obj = sub {
+ my $obj = '' . $_[0];
+ $obj = '{' if $obj =~ /^\s*\{/;
+ $obj;
+};
+

 sub violates_dynamic {
  my ($self, undef, $doc) = @_;
 
 sub violates_dynamic {
  my ($self, undef, $doc) = @_;
 

- my $src;
-
+ my ($src, $file);

  if ($doc->isa('PPI::Document::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 {
   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 @errs;

- my $offset  = 6;
+ my $hook = sub { push @errs, [ @_ ] };
+

  my $wrapper = <<" WRAPPER";
  my $wrapper = <<" WRAPPER";

- {

   return;
   package main;
   return;
   package main;

-  no indirect hook => sub { push \@errs, [ \@_ ] };
-  {
-   ;
+  no strict;
+  no warnings;
+  no indirect hook => \$hook;
+  do {
+#line 1 "$file"

    $src
   }
    $src
   }

- }

  WRAPPER
 
  {
   local ($@, *_);
   eval $wrapper; ## no critic
  WRAPPER
 
  {
   local ($@, *_);
   eval $wrapper; ## no critic

-  if ($@) {
+  if (my $err = $@) {

    require Carp;
    require Carp;

-   Carp::confess("Couldn't compile the source wrapper: $@");
+   Carp::croak("Couldn't compile the source wrapper: $err");

   }
  }
 
   }
  }
 


@@ -77,8 +86,7 @@ sub violates_dynamic {
   my %errs_tags;
   for (@errs) {
    my ($obj, $meth, $line) = @$_[0, 1, 3];
   my %errs_tags;
   for (@errs) {
    my ($obj, $meth, $line) = @$_[0, 1, 3];

-   $line -= $offset;
-   my $tag = join "\0", $line, $meth, $obj;
+   my $tag = join "\0", $line, $meth, $tag_obj->($obj);

    push @{$errs_tags{$tag}}, [ $obj, $meth ];
   }
 
    push @{$errs_tags{$tag}}, [ $obj, $meth ];
   }
 


@@ -87,7 +95,7 @@ sub violates_dynamic {
    my $pos = $elt->location;
    return 0 unless $pos;
 
    my $pos = $elt->location;
    return 0 unless $pos;
 

-   my $tag = join "\0", $pos->[0], $elt, $elt->snext_sibling;
+   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;
    if (my $errs = $errs_tags{$tag}) {
     push @violations, do { my $e = pop @$errs; push @$e, $elt; $e };
     delete $errs_tags{$tag} unless @$errs;


@@ -100,21 +108,37 @@ sub violates_dynamic {
 
  return map {
   my ($obj, $meth, $elt) = @$_;
 
  return map {
   my ($obj, $meth, $elt) = @$_;

+  $obj = ($obj =~ /^\s*\{/) ? "a block" : "object \"$obj\"";

   $self->violation(
   $self->violation(

-   "Indirect call of method \"$meth\" on object \"$obj\"",
+   "Indirect call of method \"$meth\" on $obj",

    "You really wanted $obj\->$meth",
    $elt,
   );
  } @violations;
 }
 
    "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>.
 
 L<Perl::Critic>, L<Perl::Critic::Dynamic>.
 
 =head1 DEPENDENCIES
 
 L<perl> 5.8, L<Carp>.
 
 L<Perl::Critic>, L<Perl::Critic::Dynamic>.
 

-L<indirect>.
+L<indirect> 0.20.
+
+=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
 
 
 =head1 AUTHOR
 


@@ -131,11 +155,11 @@ I will be notified, and then you'll automatically be notified of progress on you
 
 You can find documentation for this module with the perldoc command.
 
 
 You can find documentation for this module with the perldoc command.
 

-    perldoc Perl::Critic::Policy::Dynamic::NoIndirect 
+    perldoc Perl::Critic::Policy::Dynamic::NoIndirect

 
 =head1 COPYRIGHT & LICENSE
 
 
 =head1 COPYRIGHT & LICENSE
 

-Copyright 2009 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011 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.
 
 
 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.