78b2b1dad86ba8fcfbe8e881f06ad79401cdec19
[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 + 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  eval <<' SNIP';
122   return;
123   no indirect ':fatal';
124   use indirect::Test1::il1 ();
125   use indirect::Test1::il2 ();
126  SNIP
127  is $@, '', 'RT #47902';
128 }
129
130 __DATA__
131 my $a = new P1;
132
133 {
134  no indirect;
135  my $b = new P2;
136  {
137   my $c = new P3;
138  }
139  {
140   use indirect;
141   my $d = new P4;
142  }
143  my $e = new P5;
144 }
145
146 my $f = new P6;
147
148 no indirect;
149
150 my $g = new P7;
151
152 use indirect;
153
154 my $h = new P8;
155
156 {
157  no indirect;
158  eval { my $i = new P9 };
159 }
160
161 eval { no indirect; my $j = new P10 };
162
163 {
164  use indirect;
165  new P11 do { use indirect; new P12 };
166 }
167
168 {
169  use indirect;
170  new P13 do { no indirect; new P14 };
171 }
172
173 {
174  no indirect;
175  new P15 do { use indirect; new P16 };
176 }
177
178 {
179  no indirect;
180  new P17 do { no indirect; new P18 };
181 }