]> git.vpit.fr Git - perl/modules/indirect.git/blob - 30-scope.t
e83819de0b6c6b8ab47a89e179e226cf0ae99320
[perl/modules/indirect.git] / 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) + 3 + 3 + 3 + 5 + 4 + 5;
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 # This test may not fail for the old version when ran in taint mode
157 {
158  my $err = eval <<' SNIP';
159   use indirect::TestRequired4::a0;
160   indirect::TestRequired4::a0::error();
161  SNIP
162  like $err, qr/^Can't locate object method "new" via package "X"/, 'RT #50570';
163 }
164
165 # This test must be in the topmost scope
166 BEGIN { eval 'use indirect::TestRequired5::a0' }
167 my $err = indirect::TestRequired5::a0::error();
168 like $err, qr/^Can't locate object method "new" via package "X"/,
169            'identifying requires by their eval context pointer is not enough';
170
171 {
172  my @w;
173  no indirect hook => sub { push @w, indirect::msg(@_) };
174  use indirect::TestRequired6;
175  indirect::TestRequired6::bar();
176  is_deeply \@w, [ ], 'indirect syntax in sub';
177  @w = ();
178  indirect::TestRequired6::baz();
179  is_deeply \@w, [ ], 'indirect syntax in eval in sub';
180 }
181
182 __DATA__
183 my $a = new P1;
184
185 {
186  no indirect;
187  my $b = new P2;
188  {
189   my $c = new P3;
190  }
191  {
192   use indirect;
193   my $d = new P4;
194  }
195  my $e = new P5;
196 }
197
198 my $f = new P6;
199
200 no indirect;
201
202 my $g = new P7;
203
204 use indirect;
205
206 my $h = new P8;
207
208 {
209  no indirect;
210  eval { my $i = new P9 };
211 }
212
213 eval { no indirect; my $j = new P10 };
214
215 {
216  use indirect;
217  new P11 do { use indirect; new P12 };
218 }
219
220 {
221  use indirect;
222  new P13 do { no indirect; new P14 };
223 }
224
225 {
226  no indirect;
227  new P15 do { use indirect; new P16 };
228 }
229
230 {
231  no indirect;
232  new P17 do { no indirect; new P18 };
233 }