t/30-scope.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 my $tests;
   7 BEGIN { $tests = 18 }
   8
   9 use Test::More tests => (1 + $tests + 1) + 3 + 3 + 3 + 5 + 1;
  10
  11 use lib 't/lib';
  12
  13 my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18;
  14
  15 sub expect {
  16  my ($pkg, $file) = @_;
  17  $file = $file ? quotemeta $file : '\(eval \d+\)';
  18  qr/^warn:Indirect call of method "new" on object "$pkg" at $file line \d+/;
  19 }
  20
  21 {
  22  my $code = do { local $/; <DATA> };
  23  my (%res, $num, @left);
  24
  25  {
  26   local $SIG{__WARN__} = sub {
  27    ++$num;
  28    my $w = join '', 'warn:', @_;
  29    if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
  30     $res{$1} = $w;
  31    } else {
  32     push @left, "[$num] $w";
  33    }
  34   };
  35   eval "return; $code";
  36  }
  37  is $@, '', 'DATA compiled fine';
  38
  39  for (1 .. $tests) {
  40   my $w = $res{$_};
  41   if ($wrong{$_}) {
  42    like $w, expect("P$_"), "$_ should warn";
  43   } else {
  44    is   $w, undef,         "$_ shouldn't warn";
  45   }
  46  }
  47
  48  is @left, 0, 'nothing left';
  49  diag "Extraneous warnings:\n", @left if @left;
  50 }
  51
  52 {
  53  my @w;
  54  {
  55   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  56   eval 'return; no indirect; my $x = new Foo';
  57  }
  58  is   $@,    '',            "eval 'no indirect; my \$x = new Foo'";
  59  is   @w,    1,             'got one warning';
  60  diag join "\n", 'All warnings:', @w if @w > 1;
  61  like $w[0], expect('Foo'), 'correct warning';
  62 }
  63
  64 {
  65  my @w;
  66  {
  67   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  68   {
  69    no indirect;
  70    eval 'return; my $x = new Bar';
  71   }
  72  }
  73  is $@, '', "no indirect; eval 'my \$x = new Bar'";
  74  if ($] < 5.009005) {
  75   is   @w,   0,              'no warnings caught';
  76   pass 'placeholder';
  77  } else {
  78   is   @w,    1,             'got one warning';
  79   diag join "\n", 'All warnings:', @w if @w > 1;
  80   like $w[0], expect('Bar'), 'correct warning';
  81  }
  82 }
  83
  84 {
  85  my @w;
  86  {
  87   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  88   eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;";
  89  }
  90  is   $@,    '',            'first require test doesn\'t croak prematurely';
  91  is   @w,    1,             'first require threw only one warning';
  92  diag join "\n", 'All warnings:', @w if @w > 1;
  93  like $w[0], expect('Foo'), 'first require test catch errors in current scope';
  94 }
  95
  96 {
  97  my @w;
  98  {
  99   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
 100   eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;";
 101  }
 102  is   $@, '', 'second require test doesn\'t croak prematurely';
 103  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
 104  my $w = shift @w;
 105  like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'),
 106                                      'second require test caught error for Baz';
 107  SKIP: {
 108   skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1
 109                                                                if $] < 5.009005;
 110   $w = shift @w;
 111   like $w, expect('Blech'), 'second require test caught error for Blech';
 112  }
 113  $w = shift @w;
 114  like       $w, expect('Bar'), 'second require test caught error for Bar';
 115  is_deeply \@w, [ ],           'second require test doesn\'t have more errors';
 116 }
 117
 118 {
 119  eval <<' SNIP';
 120   return;
 121   no indirect ':fatal';
 122   use indirect::Test1::il1 ();
 123   use indirect::Test1::il2 ();
 124  SNIP
 125  is $@, '', 'RT #47902';
 126 }
 127
 128 __DATA__
 129 my $a = new P1;
 130
 131 {
 132  no indirect;
 133  my $b = new P2;
 134  {
 135   my $c = new P3;
 136  }
 137  {
 138   use indirect;
 139   my $d = new P4;
 140  }
 141  my $e = new P5;
 142 }
 143
 144 my $f = new P6;
 145
 146 no indirect;
 147
 148 my $g = new P7;
 149
 150 use indirect;
 151
 152 my $h = new P8;
 153
 154 {
 155  no indirect;
 156  eval { my $i = new P9 };
 157 }
 158
 159 eval { no indirect; my $j = new P10 };
 160
 161 {
 162  use indirect;
 163  new P11 do { use indirect; new P12 };
 164 }
 165
 166 {
 167  use indirect;
 168  new P13 do { no indirect; new P14 };
 169 }
 170
 171 {
 172  no indirect;
 173  new P15 do { use indirect; new P16 };
 174 }
 175
 176 {
 177  no indirect;
 178  new P17 do { no indirect; new P18 };
 179 }