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