t/30-scope.t

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 my $tests;
   7 BEGIN { $tests = 18 }
   8
   9 use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5 + 4;
  10
  11 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
  12
  13 use lib 't/lib';
  14
  15 my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18;
  16
  17 sub expect {
  18  my ($obj, $file, $prefix) = @_;
  19  $obj    = quotemeta $obj;
  20  $file   = $file           ? quotemeta $file   : '\(eval \d+\)';
  21  $prefix = defined $prefix ? quotemeta $prefix : 'warn:';
  22  qr/^${prefix}Indirect call of method "new" on object "$obj" at $file line \d+/;
  23 }
  24
  25 {
  26  my $code = do { local $/; <DATA> };
  27  my (%res, $num, @left);
  28
  29  {
  30   local $SIG{__WARN__} = sub {
  31    ++$num;
  32    my $w = join '', 'warn:', @_;
  33    if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
  34     $res{$1} = $w;
  35    } else {
  36     push @left, "[$num] $w";
  37    }
  38   };
  39   eval "return; $code";
  40  }
  41  is $@, '', 'DATA compiled fine';
  42
  43  for (1 .. $tests) {
  44   my $w = $res{$_};
  45   if ($wrong{$_}) {
  46    like $w, expect("P$_"), "$_ should warn";
  47   } else {
  48    is   $w, undef,         "$_ shouldn't warn";
  49   }
  50  }
  51
  52  is @left, 0, 'nothing left';
  53  diag "Extraneous warnings:\n", @left if @left;
  54 }
  55
  56 {
  57  my @w;
  58  {
  59   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  60   eval 'return; no indirect; my $x = new Foo';
  61  }
  62  is   $@,    '',            "eval 'no indirect; my \$x = new Foo'";
  63  is   @w,    1,             'got one warning';
  64  diag join "\n", 'All warnings:', @w if @w > 1;
  65  like $w[0], expect('Foo'), 'correct warning';
  66 }
  67
  68 {
  69  my @w;
  70  {
  71   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  72   {
  73    no indirect;
  74    eval 'return; my $x = new Bar';
  75   }
  76  }
  77  is $@, '', "no indirect; eval 'my \$x = new Bar'";
  78  if ("$]" < 5.009005) {
  79   is   @w,   0,              'no warnings caught';
  80   pass 'placeholder';
  81  } else {
  82   is   @w,    1,             'got one warning';
  83   diag join "\n", 'All warnings:', @w if @w > 1;
  84   like $w[0], expect('Bar'), 'correct warning';
  85  }
  86 }
  87
  88 SKIP: {
  89  skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 2
  90                                                              if "$]" < 5.009005;
  91  my @w;
  92  my $test = sub { eval 'return; new XYZ' };
  93  {
  94   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
  95   eval 'return; no indirect; BEGIN { $test->() }';
  96  }
  97  is   $@,    '',            'eval test doesn\'t croak prematurely';
  98  is   @w,    0,             'eval did not throw a warning';
  99  diag join "\n", 'All warnings:', @w if @w;
 100 }
 101
 102 {
 103  my @w;
 104  {
 105   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
 106   eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;";
 107  }
 108  is   $@,    '',            'first require test doesn\'t croak prematurely';
 109  is   @w,    1,             'first require threw only one warning';
 110  diag join "\n", 'All warnings:', @w if @w > 1;
 111  like $w[0], expect('Foo'), 'first require test catch errors in current scope';
 112 }
 113
 114 {
 115  my @w;
 116  {
 117   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
 118   eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;";
 119  }
 120  is   $@, '', 'second require test doesn\'t croak prematurely';
 121  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008003;
 122  my $w = shift @w;
 123  like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'),
 124                                      'second require test caught error for Baz';
 125  SKIP: {
 126   skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1
 127                                                              if "$]" < 5.009005;
 128   $w = shift @w;
 129   like $w, expect('Blech'), 'second require test caught error for Blech';
 130  }
 131  $w = shift @w;
 132  like       $w, expect('Bar'), 'second require test caught error for Bar';
 133  is_deeply \@w, [ ],           'second require test doesn\'t have more errors';
 134 }
 135
 136 {
 137  local @main::new;
 138  my (@err, @w);
 139  sub cb3 { push @err, $_[0] };
 140  local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
 141  eval <<' TESTREQUIRED3';
 142   {
 143    package indirect::TestRequired3Z;
 144    sub new { push @main::new, __PACKAGE__ }
 145    no indirect hook => \&main::cb3;
 146    use indirect::TestRequired3X;
 147    use indirect::TestRequired3Y;
 148    new indirect::TestRequired3Z;
 149   }
 150  TESTREQUIRED3
 151  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if "$]" <= 5.008003;
 152  is        $@,          '',
 153            "pragma leak when reusing callback test doesn't croak prematurely";
 154  is_deeply \@w,         [ ],
 155            "pragma leak when reusing callback test doesn't warn";
 156  is_deeply \@err,       [ map "indirect::TestRequired3$_", qw<X Z> ],
 157            "pragma leak when reusing callback test caught the right errors";
 158  is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw<X Y Z> ],
 159            "pragma leak when reusing callback test ran the three constructors";
 160 }
 161
 162 {
 163  eval <<' SNIP';
 164   return;
 165   no indirect ':fatal';
 166   use indirect::Test1::il1 ();
 167   use indirect::Test1::il2 ();
 168  SNIP
 169  is $@, '', 'RT #47902';
 170 }
 171
 172 # This test may not fail for the old version when ran in taint mode
 173 {
 174  my $err = eval <<' SNIP';
 175   use indirect::TestRequired4::a0;
 176   indirect::TestRequired4::a0::error();
 177  SNIP
 178  like $err, qr/^Can't locate object method "new" via package "X"/, 'RT #50570';
 179 }
 180
 181 # This test must be in the topmost scope
 182 BEGIN { eval 'use indirect::TestRequired5::a0' }
 183 my $err = indirect::TestRequired5::a0::error();
 184 like $err, qr/^Can't locate object method "new" via package "X"/,
 185            'identifying requires by their eval context pointer is not enough';
 186
 187 {
 188  my @w;
 189  no indirect hook => sub { push @w, indirect::msg(@_) };
 190  use indirect::TestRequired6;
 191  indirect::TestRequired6::bar();
 192  is_deeply \@w, [ ], 'indirect syntax in sub';
 193  @w = ();
 194  indirect::TestRequired6::baz();
 195  is_deeply \@w, [ ], 'indirect syntax in eval in sub';
 196 }
 197
 198 {
 199  local $@;
 200  eval { require indirect::Test2 };
 201  is $@, '', 'direct call in string is not fooled by newlines';
 202 }
 203
 204 {
 205  local $@;
 206  eval { require indirect::Test3 };
 207  like $@, expect('$x', 't/lib/indirect/Test3.pm', ''),
 208           'indirect call in string is not fooled by newlines';
 209 }
 210
 211 {
 212  local $@;
 213  eval { require indirect::Test4 };
 214  is $@, '', 'direct call in string is not fooled by more newlines';
 215 }
 216
 217 {
 218  local $@;
 219  eval { require indirect::Test5 };
 220  is $@, '', 'direct call in sort in string is not fooled by newlines';
 221 }
 222
 223 __DATA__
 224 my $a = new P1;
 225
 226 {
 227  no indirect;
 228  my $b = new P2;
 229  {
 230   my $c = new P3;
 231  }
 232  {
 233   use indirect;
 234   my $d = new P4;
 235  }
 236  my $e = new P5;
 237 }
 238
 239 my $f = new P6;
 240
 241 no indirect;
 242
 243 my $g = new P7;
 244
 245 use indirect;
 246
 247 my $h = new P8;
 248
 249 {
 250  no indirect;
 251  eval { my $i = new P9 };
 252 }
 253
 254 eval { no indirect; my $j = new P10 };
 255
 256 {
 257  use indirect;
 258  new P11 do { use indirect; new P12 };
 259 }
 260
 261 {
 262  use indirect;
 263  new P13 do { no indirect; new P14 };
 264 }
 265
 266 {
 267  no indirect;
 268  new P15 do { use indirect; new P16 };
 269 }
 270
 271 {
 272  no indirect;
 273  new P17 do { no indirect; new P18 };
 274 }