X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=t%2F30-scope.t;h=956b71ed684fa1e66021d9441ff39cdd6e782848;hp=2b937f78fc63882e8df604ecef21626e1a0569d6;hb=2286eff4b9037d37be6268664973754e10c08924;hpb=4cb0e2cc26fbe39a7a040b090b1a1e6c2380af0f diff --git a/t/30-scope.t b/t/30-scope.t index 2b937f7..956b71e 100644 --- a/t/30-scope.t +++ b/t/30-scope.t @@ -1,4 +1,4 @@ -#!perl -T +#!perl use strict; use warnings; @@ -6,7 +6,9 @@ use warnings; my $tests; BEGIN { $tests = 18 } -use Test::More tests => 1 + $tests + 1 + 2 + 3 + 5 + 1; +use Test::More tests => (1 + $tests + 1) + 3 + 3 + 3 + 5 + 4 + 3; + +BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } use lib 't/lib'; @@ -14,13 +16,14 @@ my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18; sub expect { my ($pkg, $file) = @_; - $file = $file ? quotemeta $file : '\(eval\s+\d+\)'; - return qr/^warn:Indirect\s+call\s+of\s+method\s+"new"\s+on\s+object\s+"$pkg"\s+at\s+$file\s+line\s+\d+/; + $file = $file ? quotemeta $file : '\(eval \d+\)'; + qr/^warn:Indirect call of method "new" on object "$pkg" at $file line \d+/; } { my $code = do { local $/; }; my (%res, $num, @left); + { local $SIG{__WARN__} = sub { ++$num; @@ -31,65 +34,75 @@ sub expect { push @left, "[$num] $w"; } }; - eval "die qq{ok\\n}; $code"; - is($@, "ok\n", 'DATA compiled fine'); + eval "return; $code"; } + is $@, '', 'DATA compiled fine'; + for (1 .. $tests) { my $w = $res{$_}; if ($wrong{$_}) { - like($w, expect("P$_"), "$_ should warn"); + like $w, expect("P$_"), "$_ should warn"; } else { - is($w, undef, "$_ shouldn't warn"); + is $w, undef, "$_ shouldn't warn"; } } - is(@left, 0, 'nothing left'); + + is @left, 0, 'nothing left'; diag "Extraneous warnings:\n", @left if @left; } { - my $w = ''; - local $SIG{__WARN__} = sub { - $w = 'more than 2 warnings' if $w; - $w = join '', 'warn:', @_ - }; + my @w; { - eval 'no indirect; my $x = new Foo'; - like($w, expect('Foo'), "eval 'no indirect; my \$x = new Foo'"); + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; + eval 'return; no indirect; my $x = new Foo'; } - $w = ''; + is $@, '', "eval 'no indirect; my \$x = new Foo'"; + is @w, 1, 'got one warning'; + diag join "\n", 'All warnings:', @w if @w > 1; + like $w[0], expect('Foo'), 'correct warning'; +} + +{ + my @w; { + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; { no indirect; - eval 'my $x = new Bar'; - } - if ($] < 5.009005) { - is($w, '', "eval 'no indirect; my \$x = new Bar'"); - } else { - like($w, expect('Bar'), "no indirect; eval 'my \$x = new Bar'"); + eval 'return; my $x = new Bar'; } } + is $@, '', "no indirect; eval 'my \$x = new Bar'"; + if ($] < 5.009005) { + is @w, 0, 'no warnings caught'; + pass 'placeholder'; + } else { + is @w, 1, 'got one warning'; + diag join "\n", 'All warnings:', @w if @w > 1; + like $w[0], expect('Bar'), 'correct warning'; + } } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; - eval "die qq{ok\\n}; no indirect; use indirect::TestRequired1; my \$x = new Foo;"; + eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;"; } - is $@, "ok\n", 'first require test doesn\'t croak prematurely'; - my $w = shift @w; - like $w, expect('Foo'), 'first require test catch errors in current scope'; - is_deeply \@w, [ ], 'first require test doesn\'t propagate into the required file'; + is $@, '', 'first require test doesn\'t croak prematurely'; + is @w, 1, 'first require threw only one warning'; + diag join "\n", 'All warnings:', @w if @w > 1; + like $w[0], expect('Foo'), 'first require test catch errors in current scope'; } { my @w; { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; - eval "die qq{ok\\n}; no indirect; use indirect::TestRequired2; my \$x = new Bar;"; + eval "return; no indirect; use indirect::TestRequired2; my \$x = new Bar;"; } + is $@, '', 'second require test doesn\'t croak prematurely'; @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003; - is $@, "ok\n", 'second require test doesn\'t croak prematurely'; my $w = shift @w; like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'), 'second require test caught error for Baz'; @@ -104,6 +117,32 @@ sub expect { is_deeply \@w, [ ], 'second require test doesn\'t have more errors'; } +{ + local @main::new; + my (@err, @w); + sub cb3 { push @err, $_[0] }; + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; + eval <<' TESTREQUIRED3'; + { + package indirect::TestRequired3Z; + sub new { push @main::new, __PACKAGE__ } + no indirect hook => \&main::cb3; + use indirect::TestRequired3X; + use indirect::TestRequired3Y; + new indirect::TestRequired3Z; + } + TESTREQUIRED3 + @w = grep !/^warn:Attempt\s+to\s+free\s+unreferenced/, @w if $] <= 5.008003; + is $@, '', + "pragma leak when reusing callback test doesn't croak prematurely"; + is_deeply \@w, [ ], + "pragma leak when reusing callback test doesn't warn"; + is_deeply \@err, [ map "indirect::TestRequired3$_", qw/X Z/ ], + "pragma leak when reusing callback test caught the right errors"; + is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw/X Y Z/ ], + "pragma leak when reusing callback test ran the three constructors"; +} + { eval <<' SNIP'; return; @@ -114,6 +153,21 @@ sub expect { is $@, '', 'RT #47902'; } +# This test may not fail for the old version when ran in taint mode +{ + my $err = eval <<' SNIP'; + use indirect::TestRequired4::a0; + indirect::TestRequired4::a0::error(); + SNIP + like $err, qr/^Can't locate object method "new" via package "X"/, 'RT #50570'; +} + +# This test must be in the topmost scope +BEGIN { eval 'use indirect::TestRequired5::a0' } +my $err = indirect::TestRequired5::a0::error(); +like $err, qr/^Can't locate object method "new" via package "X"/, + 'identifying requires by their eval context pointer is not enough'; + __DATA__ my $a = new P1;