X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2Findirect.git;a=blobdiff_plain;f=t%2F30-scope.t;h=a62e55e1c52ee83fda4a2eecea1e752b3e9c52ec;hp=2eceddb401b03cb92981e3763ee0c5d3401515b5;hb=76861cbb848c770203b09f413c9c65ca58c808c8;hpb=93e46f6f746b5a546672c36dc0608aa035abee37 diff --git a/t/30-scope.t b/t/30-scope.t index 2eceddb..a62e55e 100644 --- a/t/30-scope.t +++ b/t/30-scope.t @@ -3,56 +3,272 @@ use strict; use warnings; -my $total = 8; +my $tests; +BEGIN { $tests = 18 } -use Test::More; +use Test::More tests => (1 + $tests + 1) + 2 + 3 + 3 + 3 + 5 + 4 + 5 + 4; -use IPC::Cmd qw/run/; +BEGIN { delete $ENV{PERL_INDIRECT_PM_DISABLE} } -(my $success, my $err_code, undef, undef, my $stderr) - = run command => [ - $^X, - map('-I' . $_, @INC), - $ENV{PERL5OPT} || '', - '-c', - 't/data/mixed.d' - ]; +use lib 't/lib'; -plan skip_all => "Couldn't capture buffers" if $success and not defined $stderr; -plan tests => $total + 1; +my %wrong = map { $_ => 1 } 2, 3, 5, 7, 9, 10, 14, 15, 17, 18; -$stderr = join '', @$stderr; -unless ($success) { - diag $stderr; - diag "Failed to execute data file (error $err_code)"; - fail "Couldn't run test $_" for 1 .. $total + 1; - exit $total + 1; +sub expect { + my ($obj, $file, $prefix) = @_; + $obj = quotemeta $obj; + $file = $file ? quotemeta $file : '\(eval \d+\)'; + $prefix = defined $prefix ? quotemeta $prefix : 'warn:'; + qr/^${prefix}Indirect call of method "new" on object "$obj" at $file line \d+/; } -my %fail = map { $_ => 1 } 2, 3, 5, 7; -my %failed; -my $extra_fail = 0; +{ + my $code = do { local $/; }; + my (%res, $num, @left); -while ($stderr =~ /^Indirect\s+call\s+of\s+method\s+"([^"]+)"\s+on\s+object\s+"([^"]+)"/mg) { - my ($m, $o) = ($1, $2); - my $id; - if ($o =~ /^P(\d+)$/) { - $id = $1; - } else { - diag "$m $o"; - ++$extra_fail; - } - if ($id) { - if (exists $fail{$id}) { - pass("test $id failed as expected"); - delete $fail{$id}; - $failed{$id} = 1; + { + local $SIG{__WARN__} = sub { + ++$num; + my $w = join '', 'warn:', @_; + if ($w =~ /"P(\d+)"/ and not exists $res{$1}) { + $res{$1} = $w; + } else { + push @left, "[$num] $w"; + } + }; + eval "return; $code"; + } + is $@, '', 'DATA compiled fine'; + + for (1 .. $tests) { + my $w = $res{$_}; + if ($wrong{$_}) { + like $w, expect("P$_"), "$_ should warn"; } else { - fail("test $id shouldn't have failed"); + is $w, undef, "$_ shouldn't warn"; + } + } + + is @left, 0, 'nothing left'; + diag "Extraneous warnings:\n", @left if @left; +} + +{ + my @w; + { + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; + eval 'return; no indirect; my $x = new Foo'; + } + 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 'return; my $x = new Bar'; } } + is $@, '', "no indirect; eval 'my \$x = new Bar'"; + if ("$]" < 5.009_005) { + 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'; + } +} + +SKIP: { + skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 2 + if "$]" < 5.009_005; + my @w; + my $test = sub { eval 'return; new XYZ' }; + { + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; + eval 'return; no indirect; BEGIN { $test->() }'; + } + is $@, '', 'eval test doesn\'t croak prematurely'; + is @w, 0, 'eval did not throw a warning'; + diag join "\n", 'All warnings:', @w if @w; } -pass("test $_ hasn't failed") for grep { !$failed{$_} } 1 .. $total; -fail("test $_ should have failed") for sort { $a <=> $b } keys %fail; -is($extra_fail, 0, 'no extra fails'); +{ + my @w; + { + local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; + eval "return; no indirect; use indirect::TestRequired1; my \$x = new Foo;"; + } + 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 "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.008_003; + my $w = shift @w; + like $w, expect('Baz', 't/lib/indirect/TestRequired2.pm'), + 'second require test caught error for Baz'; + SKIP: { + skip 'The pragma doesn\'t propagte into eval STRING before perl 5.10' => 1 + if "$]" < 5.009_005; + $w = shift @w; + like $w, expect('Blech'), 'second require test caught error for Blech'; + } + $w = shift @w; + like $w, expect('Bar'), 'second require test caught error for Bar'; + 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.008_003; + 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 ], + "pragma leak when reusing callback test caught the right errors"; + is_deeply \@main::new, [ map "indirect::TestRequired3$_", qw ], + "pragma leak when reusing callback test ran the three constructors"; +} + +{ + eval <<' SNIP'; + return; + no indirect ':fatal'; + use indirect::Test1::il1 (); + use indirect::Test1::il2 (); + SNIP + 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'; + +{ + my @w; + no indirect hook => sub { push @w, indirect::msg(@_) }; + use indirect::TestRequired6; + indirect::TestRequired6::bar(); + is_deeply \@w, [ ], 'indirect syntax in sub'; + @w = (); + indirect::TestRequired6::baz(); + is_deeply \@w, [ ], 'indirect syntax in eval in sub'; +} + +{ + local $@; + eval { require indirect::Test2 }; + is $@, '', 'direct call in string is not fooled by newlines'; +} + +{ + local $@; + eval { require indirect::Test3 }; + like $@, expect('$x', 't/lib/indirect/Test3.pm', ''), + 'indirect call in string is not fooled by newlines'; +} + +{ + local $@; + eval { require indirect::Test4 }; + is $@, '', 'direct call in string is not fooled by more newlines'; +} + +{ + local $@; + eval { require indirect::Test5 }; + is $@, '', 'direct call in sort in string is not fooled by newlines'; +} + +__DATA__ +my $a = new P1; + +{ + no indirect; + my $b = new P2; + { + my $c = new P3; + } + { + use indirect; + my $d = new P4; + } + my $e = new P5; +} + +my $f = new P6; + +no indirect; + +my $g = new P7; + +use indirect; + +my $h = new P8; + +{ + no indirect; + eval { my $i = new P9 }; +} + +eval { no indirect; my $j = new P10 }; + +{ + use indirect; + new P11 do { use indirect; new P12 }; +} + +{ + use indirect; + new P13 do { no indirect; new P14 }; +} + +{ + no indirect; + new P15 do { use indirect; new P16 }; +} + +{ + no indirect; + new P17 do { no indirect; new P18 }; +}