t/structure/no_indirect_object_notation.t

   1 use strict;
   2 use lib 't';
   3 use Support::Files;
   4 use Test::More;
   5
   6 if (eval { require PPI; 1 }) {
   7   plan tests => scalar(@Support::Files::testitems);
   8 } else {
   9   plan skip_all => "PPI not installed";
  10 }
  11
  12 my @testitems = @Support::Files::testitems;
  13
  14 foreach my $file (@testitems) {
  15   my $clean = 1;
  16   my $source;
  17   {
  18     # due to a bug in PPI it cannot determine the encoding of a source file by
  19     # use utf8; normaly this would be no problem but some people instist on
  20     # putting strange stuff into the source. as a workaround read in the source
  21     # with :utf8 layer and pass it to PPI by reference
  22     # there are still some latin chars, but it's not the purpose of this test
  23     # to find them, so warnings about it will be ignored
  24     local $^W = 0; # don't care about invalid chars in comments
  25     local $/ = undef;
  26     open my $fh, '<:utf8', $file or die $!;
  27     $source = <$fh>;
  28   }
  29
  30   my $doc = PPI::Document->new(\$source) or do {
  31     print "?: PPI error for file $file: " . PPI::Document::errstr() . "\n";
  32     ok 0, $file;
  33     next;
  34   };
  35   my $stmts = $doc->find(sub { $_[1]->isa('PPI::Token::Word') && $_[1]->content eq 'new' });
  36
  37   for my $stmt (@{ $stmts || [] }) {
  38     my @schildren = $stmt->parent->schildren;
  39     for (0..$#schildren-1) {
  40       my $this = $schildren[$_];
  41       my $next = $schildren[$_+1];
  42
  43       next unless $this->isa('PPI::Token::Word');
  44       next unless $this->content eq 'new';
  45       next unless $next->isa('PPI::Token::Word');
  46
  47       # suspicious. 2 barewords in a row, with the first being 'new'
  48       # but maybe its somethiing like: Obj->new param1 => ...
  49       # check if the one before exists and is a ->
  50       next if $_ == 0 || ($schildren[$_-1]->isa('PPI::Token::Operator') && $schildren[$_-1]->content eq '->');
  51
  52       $clean = 0;
  53       print "?: @{[ $this->content, $next->content ]} \n";
  54     }
  55   }
  56
  57   ok $clean, $file;
  58 }