Use the hint pointer as the unique identifier for the %^H entry
[perl/modules/indirect.git] / 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 + 4 + 1;
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 ($pkg, $file) = @_;
19  $file = $file ? quotemeta $file : '\(eval \d+\)';
20  qr/^warn:Indirect call of method "new" on object "$pkg" at $file line \d+/;
21 }
22
23 {
24  my $code = do { local $/; <DATA> };
25  my (%res, $num, @left);
26
27  {
28   local $SIG{__WARN__} = sub {
29    ++$num;
30    my $w = join '', 'warn:', @_;
31    if ($w =~ /"P(\d+)"/ and not exists $res{$1}) {
32     $res{$1} = $w;
33    } else {
34     push @left, "[$num] $w";
35    }
36   };
37   eval "return; $code";
38  }
39  is $@, '', 'DATA compiled fine';
40
41  for (1 .. $tests) {
42   my $w = $res{$_};
43   if ($wrong{$_}) {
44    like $w, expect("P$_"), "$_ should warn";
45   } else {
46    is   $w, undef,         "$_ shouldn't warn";
47   }
48  }
49
50  is @left, 0, 'nothing left';
51  diag "Extraneous warnings:\n", @left if @left;
52 }
53
54 {
55  my @w;
56  {
57   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
58   eval 'return; no indirect; my $x = new Foo';
59  }
60  is   $@,    '',            "eval 'no indirect; my \$x = new Foo'";
61  is   @w,    1,             'got one warning';
62  diag join "\n", 'All warnings:', @w if @w > 1;
63  like $w[0], expect('Foo'), 'correct warning';
64 }
65
66 {
67  my @w;
68  {
69   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
70   {
71    no indirect;
72    eval 'return; my $x = new Bar';
73   }
74  }
75  is $@, '', "no indirect; eval 'my \$x = new Bar'";
76  if ($] < 5.009005) {
77   is   @w,   0,              'no warnings caught';
78   pass 'placeholder';
79  } else {
80   is   @w,    1,             'got one warning';
81   diag join "\n", 'All warnings:', @w if @w > 1;
82   like $w[0], expect('Bar'), 'correct warning';
83  }
84 }
85
86 {
87  my @w;
88  {
89   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
90   eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;";
91  }
92  is   $@,    '',            'first require test doesn\'t croak prematurely';
93  is   @w,    1,             'first require threw only one warning';
94  diag join "\n", 'All warnings:', @w if @w > 1;
95  like $w[0], expect('Foo'), 'first require test catch errors in current scope';
96 }
97
98 {
99  my @w;
100  {
101   local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
102   eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;";
103  }
104  is   $@, '', 'second require test doesn\'t croak prematurely';
105  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
106  my $w = shift @w;
107  like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'),
108                                      'second require test caught error for Baz';
109  SKIP: {
110   skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1
111                                                                if $] < 5.009005;
112   $w = shift @w;
113   like $w, expect('Blech'), 'second require test caught error for Blech';
114  }
115  $w = shift @w;
116  like       $w, expect('Bar'), 'second require test caught error for Bar';
117  is_deeply \@w, [ ],           'second require test doesn\'t have more errors';
118 }
119
120 {
121  local @main::new;
122  my (@err, @w);
123  sub cb3 { push @err, $_[0] };
124  local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
125  eval <<' TESTREQUIRED3';
126   {
127    package indirect::TestRequired3Z;
128    sub new { push @main::new, __PACKAGE__ }
129    no indirect hook => \&main::cb3;
130    use indirect::TestRequired3X;
131    use indirect::TestRequired3Y;
132    new indirect::TestRequired3Z;
133   }
134  TESTREQUIRED3
135  @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003;
136  is        $@,          '',
137            "pragma leak when reusing callback test doesn't croak prematurely";
138  is_deeply \@w,         [ ],
139            "pragma leak when reusing callback test doesn't warn";
140  is_deeply \@err,       [ map "indirect::TestRequired3$_", qw/X Z/ ],
141            "pragma leak when reusing callback test caught the right errors";
142  is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw/X Y Z/ ],
143            "pragma leak when reusing callback test ran the three constructors";
144 }
145
146 {
147  eval <<' SNIP';
148   return;
149   no indirect ':fatal';
150   use indirect::Test1::il1 ();
151   use indirect::Test1::il2 ();
152  SNIP
153  is $@, '', 'RT #47902';
154 }
155
156 __DATA__
157 my $a = new P1;
158
159 {
160  no indirect;
161  my $b = new P2;
162  {
163   my $c = new P3;
164  }
165  {
166   use indirect;
167   my $d = new P4;
168  }
169  my $e = new P5;
170 }
171
172 my $f = new P6;
173
174 no indirect;
175
176 my $g = new P7;
177
178 use indirect;
179
180 my $h = new P8;
181
182 {
183  no indirect;
184  eval { my $i = new P9 };
185 }
186
187 eval { no indirect; my $j = new P10 };
188
189 {
190  use indirect;
191  new P11 do { use indirect; new P12 };
192 }
193
194 {
195  use indirect;
196  new P13 do { no indirect; new P14 };
197 }
198
199 {
200  no indirect;
201  new P15 do { use indirect; new P16 };
202 }
203
204 {
205  no indirect;
206  new P17 do { no indirect; new P18 };
207 }