]> git.vpit.fr Git - perl/modules/indirect.git/blob - t/21-bad.t
Update VPIT::TestHelpers to 3c878c7c
[perl/modules/indirect.git] / t / 21-bad.t
1 #!perl -T
2
3 package NotEmpty;
4
5 sub new;
6
7 package main;
8
9 use strict;
10 use warnings;
11
12 my ($tests, $reports);
13 BEGIN {
14  $tests   = 88;
15  $reports = 100;
16 }
17
18 use Test::More tests => 3 * (4 * $tests + $reports) + 4;
19
20 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
21
22 my ($obj, $x);
23 our ($y, $bloop);
24
25 sub expect {
26  my ($expected) = @_;
27
28  die unless $expected;
29
30  map {
31   my ($meth, $obj, $file, $line) = @$_;
32   $meth = quotemeta $meth;
33   $obj  = ($obj =~ /^\s*\{/) ? "a block" : "object \"\Q$obj\E\"";
34   $file = '\((?:re_)?eval \d+\)' unless defined $file;
35   $line = '\d+'                  unless defined $line;
36   qr/^Indirect call of method "$meth" on $obj at $file line $line/
37  } eval $expected;
38 }
39
40 my @warns;
41
42 sub try {
43  my ($code) = @_;
44
45  @warns = ();
46  {
47   local $SIG{__WARN__} = sub { push @warns, @_ };
48   eval $code;
49  }
50 }
51
52 {
53  local $/ = "####";
54  while (<DATA>) {
55   chomp;
56   s/\s*$//;
57   s/(.*?)$//m;
58   my ($skip, $prefix) = split /#+/, $1;
59   $skip   = 0  unless defined $skip;
60   $prefix = '' unless defined $prefix;
61   s/\s*//;
62
63 SKIP:
64   {
65    if (do { local $@; eval $skip }) {
66     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
67     my @expected = expect($expected);
68     skip "$_: $skip" => 3 * (4 + @expected);
69    }
70
71    {
72     local $_ = $_;
73     s/Pkg/Empty/g;
74     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
75     my @expected = expect($expected);
76
77     try "return; $prefix; use indirect; $code";
78     is $@,     '', "use indirect: $code";
79     is @warns, 0,  'correct number of reports';
80
81     try "return; $prefix; no indirect; $code";
82     is $@,     '',        "no indirect: $code";
83     is @warns, @expected, 'correct number of reports';
84     for my $i (0 .. $#expected) {
85      like $warns[$i], $expected[$i], "report $i is correct";
86     }
87    }
88
89    {
90     local $_ = $_;
91     s/Pkg/NotEmpty/g;
92     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
93     my @expected = expect($expected);
94
95     try "return; $prefix; use indirect; $code";
96     is $@,     '', "use indirect, defined: $code";
97     is @warns, 0,  'correct number of reports';
98
99     try "return; $prefix; no indirect; $code";
100     is $@,     '',        "no indirect, defined: $code";
101     is @warns, @expected, 'correct number of reports';
102     for my $i (0 .. $#expected) {
103      like $warns[$i], $expected[$i], "report $i is correct";
104     }
105    }
106
107 SKIP:
108    {
109     local $_ = $_;
110     s/Pkg/Empty/g;
111     my ($code, $expected) = split /^-{4,}$/m, $_, 2;
112     my @expected = expect($expected);
113     skip 'No space tests on perl 5.11' => 4 + @expected
114                                               if "$]" >= 5.011 and "$]" < 5.012;
115     $code =~ s/\$/\$ \n\t /g;
116
117     try "return; $prefix; use indirect; $code";
118     is $@,     '', "use indirect, spaces: $code";
119     is @warns, 0,  'correct number of reports';
120
121     try "return; $prefix; no indirect; $code";
122     is $@,     '',        "no indirect, spaces: $code";
123     is @warns, @expected, 'correct number of reports';
124     for my $i (0 .. $#expected) {
125      like $warns[$i], $expected[$i], "report $i is correct";
126     }
127    }
128   }
129  }
130 }
131
132 eval {
133  my @warns;
134  {
135   local $SIG{__WARN__} = sub { push @warns, @_ };
136   eval "return; no indirect 'whatever'; \$obj = new Pkg1;";
137  }
138  is        $@,      '',  'no indirect "whatever" didn\'t croak';
139  is        @warns,  1,   'only one warning';
140  my $warn = shift @warns;
141  like      $warn,   qr/^Indirect call of method "new" on object "Pkg1"/,
142                          'no indirect "whatever" enables the pragma';
143  is_deeply \@warns, [ ], 'nothing more';
144 }
145
146 __DATA__
147
148 $obj = new Pkg;
149 ----
150 [ 'new', 'Pkg' ]
151 ####
152 $obj = new Pkg if 0;
153 ----
154 [ 'new', 'Pkg' ]
155 ####
156 $obj = new Pkg();
157 ----
158 [ 'new', 'Pkg' ]
159 ####
160 $obj = new Pkg(1);
161 ----
162 [ 'new', 'Pkg' ]
163 ####
164 $obj = new Pkg(1, 2);
165 ----
166 [ 'new', 'Pkg' ]
167 ####
168 $obj = new        Pkg            ;
169 ----
170 [ 'new', 'Pkg' ]
171 ####
172 $obj = new        Pkg     (      )      ;
173 ----
174 [ 'new', 'Pkg' ]
175 ####
176 $obj = new        Pkg     (      1        )     ;
177 ----
178 [ 'new', 'Pkg' ]
179 ####
180 $obj = new        Pkg     (      1        ,       2        )     ;
181 ----
182 [ 'new', 'Pkg' ]
183 ####
184 $obj = new    
185                       Pkg               
186         ;
187 ----
188 [ 'new', 'Pkg' ]
189 ####
190 $obj = new   
191                                        Pkg     (    
192                   )      ;
193 ----
194 [ 'new', 'Pkg' ]
195 ####
196 $obj =
197               new    
198     Pkg     (      1   
199             )     ;
200 ----
201 [ 'new', 'Pkg' ]
202 ####
203 $obj =
204 new      
205 Pkg    
206                    (      1        ,  
207                 2        )     ;
208 ----
209 [ 'new', 'Pkg' ]
210 ####
211 $obj = new $x;
212 ----
213 [ 'new', '$x' ]
214 ####
215 $obj = new $x();
216 ----
217 [ 'new', '$x' ]
218 ####
219 $obj = new $x('foo');
220 ----
221 [ 'new', '$x' ]
222 ####
223 $obj = new $x qq{foo}, 1;
224 ----
225 [ 'new', '$x' ]
226 ####
227 $obj = new $x qr{foo\s+bar}, 1 .. 1;
228 ----
229 [ 'new', '$x' ]
230 ####
231 $obj = new $x(qw<bar baz>);
232 ----
233 [ 'new', '$x' ]
234 ####
235 $obj = new
236           $_;
237 ----
238 [ 'new', '$_' ]
239 ####
240 $obj = new
241              $_     (        );
242 ----
243 [ 'new', '$_' ]
244 ####
245 $obj = new $_      qr/foo/  ;
246 ----
247 [ 'new', '$_' ]
248 ####
249 $obj = new $_     qq(bar baz);
250 ----
251 [ 'new', '$_' ]
252 ####
253 meh $_;
254 ----
255 [ 'meh', '$_' ]
256 ####
257 meh $_ 1, 2;
258 ----
259 [ 'meh', '$_' ]
260 ####
261 meh $$;
262 ----
263 [ 'meh', '$$' ]
264 ####
265 meh $$ 1, 2;
266 ----
267 [ 'meh', '$$' ]
268 ####
269 meh $x;
270 ----
271 [ 'meh', '$x' ]
272 ####
273 meh $x 1, 2;
274 ----
275 [ 'meh', '$x' ]
276 ####
277 meh $x, 1, 2;
278 ----
279 [ 'meh', '$x' ]
280 ####
281 meh $y;
282 ----
283 [ 'meh', '$y' ]
284 ####
285 meh $y 1, 2;
286 ----
287 [ 'meh', '$y' ]
288 ####
289 meh $y, 1, 2;
290 ----
291 [ 'meh', '$y' ]
292 #### "$]" < 5.010 # use feature 'state'; state $z
293 meh $z;
294 ----
295 [ 'meh', '$z' ]
296 #### "$]" < 5.010 # use feature 'state'; state $z
297 meh $z 1, 2;
298 ----
299 [ 'meh', '$z' ]
300 #### "$]" < 5.010 # use feature 'state'; state $z
301 meh $z, 1, 2;
302 ----
303 [ 'meh', '$z' ]
304 ####
305 package sploosh;
306 our $sploosh;
307 meh $sploosh::sploosh;
308 ----
309 [ 'meh', '$sploosh::sploosh' ]
310 ####
311 package sploosh;
312 our $sploosh;
313 meh $sploosh;
314 ----
315 [ 'meh', '$sploosh' ]
316 ####
317 package sploosh;
318 meh $main::bloop;
319 ----
320 [ 'meh', '$main::bloop' ]
321 ####
322 package sploosh;
323 meh $bloop;
324 ----
325 [ 'meh', '$bloop' ]
326 ####
327 package ma;
328 meh $bloop;
329 ----
330 [ 'meh', '$bloop' ]
331 ####
332 package sploosh;
333 our $sploosh;
334 package main;
335 meh $sploosh::sploosh;
336 ----
337 [ 'meh', '$sploosh::sploosh' ]
338 ####
339 new Pkg->wut;
340 ----
341 [ 'new', 'Pkg' ]
342 ####
343 new Pkg->wut();
344 ----
345 [ 'new', 'Pkg' ]
346 ####
347 new Pkg->wut, "Wut";
348 ----
349 [ 'new', 'Pkg' ]
350 ####
351 $obj = PkgPkg Pkg;
352 ----
353 [ 'PkgPkg', 'Pkg' ]
354 ####
355 $obj = PkgPkg Pkg; # PkgPkg Pkg
356 ----
357 [ 'PkgPkg', 'Pkg' ]
358 ####
359 $obj = new newnew;
360 ----
361 [ 'new', 'newnew' ]
362 ####
363 $obj = new newnew; # new newnew
364 ----
365 [ 'new', 'newnew' ]
366 ####
367 $obj = feh feh;
368 ----
369 [ 'feh', 'feh' ]
370 ####
371 $obj = feh feh; # feh feh
372 ----
373 [ 'feh', 'feh' ]
374 ####
375 new Pkg (meh $x)
376 ----
377 [ 'meh', '$x' ], [ 'new', 'Pkg' ]
378 ####
379 Pkg->new(meh $x)
380 ----
381 [ 'meh', '$x' ]
382 ####
383 $obj = "apple ${\(new Pkg)} pear"
384 ----
385 [ 'new', 'Pkg' ]
386 ####
387 $obj = "apple @{[new Pkg]} pear"
388 ----
389 [ 'new', 'Pkg' ]
390 ####
391 $obj = "apple ${\(new $x)} pear"
392 ----
393 [ 'new', '$x' ]
394 ####
395 $obj = "apple @{[new $x]} pear"
396 ----
397 [ 'new', '$x' ]
398 ####
399 $obj = "apple ${\(new $y)} pear"
400 ----
401 [ 'new', '$y' ]
402 ####
403 $obj = "apple @{[new $y]} pear"
404 ----
405 [ 'new', '$y' ]
406 ####
407 $obj = "apple ${\(new $x qq|${\(stuff $y)}|)} pear"
408 ----
409 [ 'stuff', '$y' ], [ 'new', '$x' ]
410 ####
411 $obj = "apple @{[new $x qq|@{[stuff $y]}|]} pear"
412 ----
413 [ 'stuff', '$y' ], [ 'new', '$x' ]
414 #### # local $_ = "foo";
415 s/foo/return; new Pkg/e;
416 ----
417 [ 'new', 'Pkg' ]
418 #### # local $_ = "bar";
419 s/foo/return; new Pkg/e;
420 ----
421 [ 'new', 'Pkg' ]
422 #### # local $_ = "foo";
423 s/foo/return; new $x/e;
424 ----
425 [ 'new', '$x' ]
426 #### # local $_ = "bar";
427 s/foo/return; new $x/e;
428 ----
429 [ 'new', '$x' ]
430 #### # local $_ = "foo";
431 s/foo/return; new $y/e;
432 ----
433 [ 'new', '$y' ]
434 #### # local $_ = "bar";
435 s/foo/return; new $y/e;
436 ----
437 [ 'new', '$y' ]
438 ####
439 "foo" =~ /(?{new Pkg})/;
440 ----
441 [ 'new', 'Pkg' ]
442 ####
443 "foo" =~ /(?{new $x})/;
444 ----
445 [ 'new', '$x' ]
446 ####
447 "foo" =~ /(?{new $y})/;
448 ----
449 [ 'new', '$y' ]
450 ####
451 "foo" =~ /(??{new Pkg})/;
452 ----
453 [ 'new', 'Pkg' ]
454 ####
455 "foo" =~ /(??{new $x})/;
456 ----
457 [ 'new', '$x' ]
458 ####
459 "foo" =~ /(??{new $y})/;
460 ----
461 [ 'new', '$y' ]
462 ####
463 meh { };
464 ----
465 [ 'meh', '{' ]
466 ####
467 meh {
468  1;
469 };
470 ----
471 [ 'meh', '{' ]
472 ####
473 meh {
474  1;
475  1;
476 };
477 ----
478 [ 'meh', '{' ]
479 ####
480 meh { new Pkg; 1; };
481 ----
482 [ 'new', 'Pkg' ], [ 'meh', '{' ]
483 ####
484 meh { feh $x; 1; };
485 ----
486 [ 'feh', '$x' ], [ 'meh', '{' ]
487 ####
488 meh { feh $x; use indirect; new Pkg; 1; };
489 ----
490 [ 'feh', '$x' ], [ 'meh', '{' ]
491 ####
492 meh { feh $y; 1; };
493 ----
494 [ 'feh', '$y' ], [ 'meh', '{' ]
495 ####
496 meh { feh $x; 1; } new Pkg, feh $y;
497 ----
498 [ 'feh', '$x' ], [ 'new', 'Pkg' ], [ 'feh', '$y' ], [ 'meh', '{' ]
499 ####
500 $obj = "apple @{[new { feh $x; meh $y; 1 }]} pear"
501 ----
502 [ 'feh', '$x' ], [ 'meh', '$y' ], [ 'new', '{' ]
503 ####
504 package __PACKAGE_;
505 new __PACKAGE_;
506 ----
507 [ 'new', '__PACKAGE_' ]
508 ####
509 package __PACKAGE___;
510 new __PACKAGE___;
511 ----
512 [ 'new', '__PACKAGE___' ]
513 ####
514 package Hurp;
515 new { __PACKAGE__ }; # Hurp
516 ----
517 [ 'new', '{' ]
518 ####
519 package __PACKAGE_;
520 new { __PACKAGE__ };
521 ----
522 [ 'new', '{' ]
523 ####
524 package __PACKAGE__;
525 new { __PACKAGE__ };
526 ----
527 [ 'new', '{' ]
528 ####
529 package __PACKAGE___;
530 new { __PACKAGE__ };
531 ----
532 [ 'new', '{' ]