]> git.vpit.fr Git - perl/modules/indirect.git/blob - t/20-good.t
Preserve previous compilation errors on fatal indirect constructs
[perl/modules/indirect.git] / t / 20-good.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 use Test::More tests => 119 * 8 + 10;
13
14 BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} }
15
16 my ($obj, $pkg, $cb, $x, @a);
17 our ($y, $meth);
18 sub meh;
19 sub zap (&);
20
21 my @warns;
22
23 sub try {
24  my ($code) = @_;
25
26  @warns = ();
27  {
28   local $SIG{__WARN__} = sub { push @warns, @_ };
29   eval $code;
30  }
31 }
32
33 {
34  local $/ = "####";
35  while (<DATA>) {
36   chomp;
37   s/\s*$//;
38   s/(.*?)$//m;
39   my ($skip, $prefix) = split /#+/, $1;
40   $skip   = 0  unless defined $skip;
41   $prefix = '' unless defined $prefix;
42   s/\s*//;
43
44 SKIP:
45   {
46    skip "$_: $skip" => 8 if eval $skip;
47
48    {
49     local $_ = $_;
50     s/Pkg/Empty/g;
51
52     try "return; $prefix; use indirect; $_";
53     is $@,     '', "use indirect: $_";
54     is @warns, 0,  'no reports';
55
56     try "return; $prefix; no indirect; $_";
57     is $@,     '', "no indirect: $_";
58     is @warns, 0,  'no reports';
59    }
60
61    {
62     local $_ = $_;
63     s/Pkg/NotEmpty/g;
64
65     try "return; $prefix; use indirect; $_";
66     is $@,     '', "use indirect, defined: $_";
67     is @warns, 0,  'no reports';
68
69     try "return; $prefix; no indirect; $_";
70     is $@,     '', "no indirect, defined: $_";
71     is @warns, 0,  'no reports';
72    }
73   }
74  }
75 }
76
77 # These tests must be run outside of eval to be meaningful.
78 {
79  sub Zlott::Owww::new { }
80
81  my (@warns, $hook, $desc, $id);
82  BEGIN {
83   $hook = sub { push @warns, indirect::msg(@_) };
84   $desc = "test sort and line endings %d: no indirect construct";
85   $id   = 1;
86  }
87
88  BEGIN { @warns = () }
89  {
90   no indirect hook => $hook;
91   my @stuff = sort Zlott::Owww
92           ->new;
93  }
94  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
95
96  BEGIN { @warns = () }
97  {
98   no indirect hook => $hook;
99   my @stuff = sort Zlott::Owww
100                ->new;
101  };
102  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
103
104  BEGIN { @warns = () }
105  {
106   no indirect hook => $hook;
107   my @stuff = sort Zlott::Owww
108                  ->new;
109  }
110  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
111
112  BEGIN { @warns = () }
113  {
114   no indirect hook => $hook;
115   my @stuff = sort Zlott::Owww
116                   ->new;
117  }
118  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
119
120  BEGIN { @warns = () }
121  {
122   no indirect hook => $hook;
123   my @stuff = sort Zlott::Owww
124                    ->new;
125  }
126  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
127
128  BEGIN { @warns = () }
129  {
130   no indirect hook => $hook;
131   my @stuff = sort Zlott::Owww
132                      ->new;
133  }
134  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
135
136  BEGIN { @warns = () }
137  {
138   no indirect hook => $hook;
139   my @stuff = sort Zlott::Owww
140                        ->new;
141  }
142  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
143
144  BEGIN { @warns = () }
145  {
146   no indirect hook => $hook;
147   my @stuff = sort Zlott::Owww
148                           ->new;
149  }
150  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
151
152  BEGIN { @warns = () }
153  {
154   no indirect hook => $hook;
155   my @stuff = sort Zlott::Owww
156                             ->new;
157  }
158  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
159
160  BEGIN { @warns = () }
161  {
162   no indirect hook => $hook;
163   my @stuff = sort Zlott::Owww
164                              ->new;
165  }
166  BEGIN { is_deeply \@warns, [ ], sprintf $desc, $id++ }
167 }
168
169 __DATA__
170
171 $obj = Pkg->new;
172 ####
173 $obj = Pkg->new();
174 ####
175 $obj = Pkg->new(1);
176 ####
177 $obj = Pkg->new(q{foo}, bar => $obj);
178 ####
179 $obj = Pkg   ->   new   ;
180 ####
181 $obj = Pkg   ->   new   (   )   ;
182 ####
183 $obj = Pkg   ->   new   (   1   )   ;
184 ####
185 $obj = Pkg   ->   new   (   'foo'   ,   bar =>   $obj   );
186 ####
187 $obj = Pkg
188             ->
189                           new   ;
190 ####
191 $obj = Pkg  
192
193       ->   
194 new   ( 
195  )   ;
196 ####
197 $obj = Pkg
198                                        ->   new   ( 
199                1   )   ;
200 ####
201 $obj = Pkg   ->
202                               new   (   "foo"
203   ,    bar     
204                =>        $obj       );
205 ####
206 $obj = new->new;
207 ####
208 $obj = new->new; # new new
209 ####
210 $obj = new->newnew;
211 ####
212 $obj = newnew->new;
213 ####
214 $obj = Pkg->$cb;
215 ####
216 $obj = Pkg->$cb();
217 ####
218 $obj = Pkg->$cb($pkg);
219 ####
220 $obj = Pkg->$cb(sub { 'foo' },  bar => $obj);
221 ####
222 $obj = Pkg->$meth;
223 ####
224 $obj =   Pkg
225    -> 
226           $meth   ( 1,   2   );
227 ####
228 $obj = $pkg->new   ;
229 ####
230 $obj = $pkg  ->   new  (   );
231 ####
232 $obj = $pkg       
233            -> 
234         new ( $pkg );
235 ####
236 $obj = 
237          $pkg
238 ->
239 new        (     qr/foo/,
240       foo => qr/bar/   );
241 ####
242 $obj 
243   =  
244 $pkg
245 ->
246 $cb
247 ;
248 ####
249 $obj = $pkg    ->   ($cb)   ();
250 ####
251 $obj = $pkg->$cb( $obj  );
252 ####
253 $obj = $pkg->$cb(qw<foo bar baz>);
254 ####
255 $obj = $pkg->$meth;
256 ####
257 $obj 
258  =
259     $pkg
260           ->
261               $meth
262   ( 1 .. 10 );
263 ####
264 $obj = $y->$cb;
265 ####
266 $obj =  $y
267   ->          $cb   (
268   'foo', 1, 2, 'bar'
269 );
270 ####
271 $obj = $y->$meth;
272 ####
273 $obj =
274   $y->
275       $meth   (
276  qr(hello),
277 );
278 ####
279 meh;
280 ####
281 meh $_;
282 ####
283 meh $x;
284 ####
285 meh $x, 1, 2;
286 ####
287 meh $y;
288 ####
289 meh $y, 1, 2;
290 #### "$]" < 5.010 # use feature 'state'; state $z
291 meh $z;
292 #### "$]" < 5.010 # use feature 'state'; state $z
293 meh $z, 1, 2;
294 ####
295 print;
296 ####
297 print $_;
298 ####
299 print $x;
300 ####
301 print $x "oh hai\n";
302 ####
303 print $y;
304 ####
305 print $y "hello thar\n";
306 #### "$]" < 5.010 # use feature 'state'; state $z
307 print $z;
308 #### "$]" < 5.010 # use feature 'state'; state $z
309 print $z "lolno\n";
310 ####
311 print STDOUT "bananananananana\n";
312 ####
313 $x->foo($pkg->$cb)
314 ####
315 $obj = "apple ${\($x->new)} pear"
316 ####
317 $obj = "apple @{[$x->new]} pear"
318 ####
319 $obj = "apple ${\($y->new)} pear"
320 ####
321 $obj = "apple @{[$y->new]} pear"
322 ####
323 $obj = "apple ${\($x->$cb)} pear"
324 ####
325 $obj = "apple @{[$x->$cb]} pear"
326 ####
327 $obj = "apple ${\($y->$cb)} pear"
328 ####
329 $obj = "apple @{[$y->$cb]} pear"
330 ####
331 $obj = "apple ${\($x->$meth)} pear"
332 ####
333 $obj = "apple @{[$x->$meth]} pear"
334 ####
335 $obj = "apple ${\($y->$meth)} pear"
336 ####
337 $obj = "apple @{[$y->$meth]} pear"
338 #### # local $_ = "foo";
339 s/foo/return; Pkg->new/e;
340 #### # local $_ = "bar";
341 s/foo/return; Pkg->new/e;
342 #### # local $_ = "foo";
343 s/foo/return; Pkg->$cb/e;
344 #### # local $_ = "bar";
345 s/foo/return; Pkg->$cb/e;
346 #### # local $_ = "foo";
347 s/foo/return; Pkg->$meth/e;
348 #### # local $_ = "bar";
349 s/foo/return; Pkg->$meth/e;
350 #### # local $_ = "foo";
351 s/foo/return; $x->new/e;
352 #### # local $_ = "bar";
353 s/foo/return; $x->new/e;
354 #### # local $_ = "foo";
355 s/foo/return; $x->$cb/e;
356 #### # local $_ = "bar";
357 s/foo/return; $x->$cb/e;
358 #### # local $_ = "foo";
359 s/foo/return; $x->$meth/e;
360 #### # local $_ = "bar";
361 s/foo/return; $x->$meth/e;
362 #### # local $_ = "foo";
363 s/foo/return; $y->new/e;
364 #### # local $_ = "bar";
365 s/foo/return; $y->new/e;
366 #### # local $_ = "foo";
367 s/foo/return; $y->$cb/e;
368 #### # local $_ = "bar";
369 s/foo/return; $y->$cb/e;
370 #### # local $_ = "foo";
371 s/foo/return; $y->$meth/e;
372 #### # local $_ = "bar";
373 s/foo/return; $y->$meth/e;
374 ####
375 "foo" =~ /(?{Pkg->new})/;
376 ####
377 "foo" =~ /(?{Pkg->$cb})/;
378 ####
379 "foo" =~ /(?{Pkg->$meth})/;
380 ####
381 "foo" =~ /(?{$x->new})/;
382 ####
383 "foo" =~ /(?{$x->$cb})/;
384 ####
385 "foo" =~ /(?{$x->$meth})/;
386 ####
387 "foo" =~ /(?{$y->new})/;
388 ####
389 "foo" =~ /(?{$y->$cb})/;
390 ####
391 "foo" =~ /(?{$y->$meth})/;
392 ####
393 exec $x $x, @a;
394 ####
395 exec { $a[0] } @a;
396 ####
397 system $x $x, @a;
398 ####
399 system { $a[0] } @a;
400 ####
401 zap { };
402 ####
403 zap { 1; };
404 ####
405 zap { 1; 1; };
406 ####
407 zap { zap { }; 1; };
408 ####
409 my @stuff = sort Pkg
410      ->new;
411 ####
412 my @stuff = sort Pkg
413               ->new;
414 ####
415 my @stuff = sort Pkg
416                ->new;
417 ####
418 my @stuff = sort Pkg
419                 ->new;
420 ####
421 my @stuff = sort Pkg
422                  ->new;
423 ####
424 my @stuff = sort Pkg
425                    ->new;
426 ####
427 my @stuff = sort Pkg
428                      ->new;
429 ####
430 my @stuff = sort Pkg
431                         ->new;
432 ####
433 sub {
434  my $self = shift;
435  return $self->new ? $self : undef;
436 }
437 ####
438 sub {
439  my $self = shift;
440  return $self ? $self->new : undef;
441 }
442 ####
443 sub {
444  my $self = shift;
445  return $_[0] ? undef : $self->new;
446 }
447 ####
448 package Hurp;
449 __PACKAGE__->new;
450 ####
451 package Hurp;
452 __PACKAGE__->new # Hurp
453 ####
454 package Hurp;
455 __PACKAGE__->new;
456 # Hurp
457 ####
458 package __PACKAGE_;
459 __PACKAGE__->new # __PACKAGE_
460 ####
461 package __PACKAGE_;
462 __PACKAGE_->new # __PACKAGE__
463 ####
464 package __PACKAGE___;
465 __PACKAGE__->new # __PACKAGE___
466 ####
467 package __PACKAGE___;
468 __PACKAGE___->new # __PACKAGE__