#!perl
# The first, basic test case for the ignore option
# was supplied by Kevin Ryde.
use strict;
use warnings;
use Test::More;
use Data::Dumper;
use English qw( -no_match_vars );
use Fatal qw(open close);
# force sorted in got/want checks
# (though checking the string display is probably a bit fragile)
$Data::Dumper::Sortkeys = 1;
BEGIN {
unless ($] >= 5.008) {
plan skip_all => 'due to test code no good for 5.006 yet';
}
plan tests => 24;
}
use lib 't/lib';
use Test::Weaken::Test;
sub divert_stderr {
my $stderr = q{};
open my $save_stderr, '>&STDERR';
close STDERR;
open STDERR, '>', \$stderr;
return sub {
open STDERR, '>&', $save_stderr;
close $save_stderr;
return $stderr;
};
}
package MyGlobal;
my %cache;
sub new {
my ( $class, $name ) = @_;
return (
$cache{$name} ||= bless {
name => $name,
array => ["something for $name"],
},
$class
);
}
package MyObject;
sub new {
my ($class) = @_;
return bless {
one => MyGlobal->new('ishtar'),
two => MyGlobal->new('ereskigal'),
}, $class;
}
package MyCycle;
sub new {
my ($class) = @_;
my $weak;
my $strong = \$weak;
my $self = \$strong;
Scalar::Util::weaken( $weak = \$self );
return bless [ \$self ], $class;
}
package DeepObject;
sub new {
my ($class) = @_;
return bless { one => { two => { three => 4 } } }, $class;
}
package main;
use Scalar::Util;
use Data::Dumper;
BEGIN {
Test::More::use_ok('Test::Weaken');
}
use lib 't/lib';
use Test::Weaken::Test;
#------------------------------------------------------------------------------
# ignore option
## use Marpa::Test::Display ignore snippet
sub ignore_my_global {
my ($probe) = @_;
return ( Scalar::Util::blessed($probe) && $probe->isa('MyGlobal') );
}
{
my $tester = Test::Weaken::leaks({ constructor => sub { MyObject->new() },
ignore => \&ignore_my_global,
});
is ($tester, undef,
'ignore of ignore_my_global() ignores everything');
}
{
# This test previously looked at all the $tester->unfreed_proberefs(), but
# think it's enough to just ask that this form results in some unfreed
# whereas ignore_my_global() above does not.
my $tester = Test::Weaken::leaks({ constructor => sub { MyObject->new() },
ignore => sub { return; }
});
ok ($tester, 'ignore of always false leaves unfreed');
}
#------------------------------------------------------------------------------
# ignore option with check_ignore() wrapper
## use Marpa::Test::Display check_ignore 1 arg snippet
my $tester = Test::Weaken::leaks(
{ constructor => sub { MyObject->new() },
ignore => Test::Weaken::check_ignore( \&ignore_my_global ),
}
);
## no Marpa::Test::Display
if ( not $tester ) {
Test::More::pass('wrappered good ignore');
}
else {
Test::Weaken::Test::is( $tester->unfreed_proberefs, q{},
'wrappered good ignore' );
}
sub overwriting_ignore {
my ($probe_ref) = @_;
${$probe_ref} = 'XXX';
return 0;
}
my $restore = divert_stderr();
my $eval_return = eval {
Test::Weaken::leaks(
{ constructor => sub { MyObject->new() },
ignore => Test::Weaken::check_ignore( \&overwriting_ignore ),
}
);
1;
};
my $stderr = &{$restore};
my $eval_result = 'proberef overwrite not caught';
if ( not $eval_return ) {
$eval_result = $EVAL_ERROR;
}
# \.? allows either "at line 170." or "at line 170"
# Normally Carp.pm makes a string ending "170\n" which die() leaves alone.
# But have seen "170.\n" which is from die() when it gets a string without
# a newline already. Dunno why the croak()s in Weaken.pm would reach there.
# Old Carp.pm might have done it if not finding a caller to report, maybe.
#
$eval_result =~ s{
[ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $
}{ at <FILE> line <LINE_NUMBER>}gxms;
Test::Weaken::Test::is(
( $stderr . $eval_result ),
<<'EOS',
Probe referent changed by ignore call
Terminating ignore callbacks after finding 1 error(s) at <FILE> line <LINE_NUMBER>
EOS
'wrappered overwriting ignore'
);
## no critic (Subroutines::RequireArgUnpacking)
# Trigger warnings, while replacing everything with its equivalent
sub buggy_ignore {
$_[0] = \${ $_[0] } if Scalar::Util::reftype $_[0] eq 'REF';
if ( Scalar::Util::reftype $_[0] eq 'ARRAY' ) {
my @temp = @{ $_[0] };
$_[0] = \@temp;
}
if ( Scalar::Util::reftype $_[0] eq 'HASH' ) {
my %temp = %{ $_[0] };
$_[0] = \%temp;
}
if ( Scalar::Util::reftype $_[0] eq 'REF' ) {
my $temp = ${ $_[0] };
$_[0] = \$temp;
}
return;
}
## use critic
my %counted_error_expected = (
0 => <<'EOS',
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
1 => <<'EOS',
Probe referent changed by ignore call
Terminating ignore callbacks after finding 1 error(s) at <FILE> line <LINE_NUMBER>
EOS
2 => <<'EOS',
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Terminating ignore callbacks after finding 2 error(s) at <FILE> line <LINE_NUMBER>
EOS
3 => <<'EOS',
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Terminating ignore callbacks after finding 3 error(s) at <FILE> line <LINE_NUMBER>
EOS
9 => <<'EOS',
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
);
sub counted_errors {
my ($error_count) = @_;
$restore = divert_stderr();
$eval_return = eval {
## use Marpa::Test::Display check_ignore snippet
Test::Weaken::leaks(
{ constructor => sub { MyObject->new() },
ignore => Test::Weaken::check_ignore(
\&buggy_ignore, $error_count
),
}
);
## no Marpa::Test::Display
};
$stderr = &{$restore};
# the exact addresses will vary, so just X them out
$stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms;
$stderr .= $EVAL_ERROR if not $eval_return;
$stderr =~ s{
[ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $
}{ at <FILE> line <LINE_NUMBER>}gxms;
Test::Weaken::Test::is(
$stderr,
$counted_error_expected{$error_count},
"wrappered overwriting ignore, max_errors=$error_count"
);
return 1;
}
counted_errors(0);
counted_errors(1);
counted_errors(2);
counted_errors(3);
counted_errors(9);
sub noop_ignore { return 0; }
$tester = Test::Weaken::leaks(
{ constructor => sub { MyCycle->new() },
ignore => \&noop_ignore,
}
);
if ( not $tester ) {
Test::More::pass('cycle w/ no-op ignore');
}
else {
Test::Weaken::Test::is( $tester->unfreed_proberefs, q{},
'cycle w/ no-op ignore' );
}
## no critic (Subroutines::RequireArgUnpacking)
sub copying_ignore {
if ( Scalar::Util::reftype $_[0] eq 'REF' ) {
my $temp = ${ $_[0] };
${ $_[0] } = $temp;
}
return 0;
}
## use critic
$tester = Test::Weaken::leaks(
{ constructor => sub { MyCycle->new() },
ignore => \©ing_ignore,
}
);
if ( not $tester ) {
Test::More::pass('cycle w/ copying ignore');
}
else {
my $unfreed = $tester->unfreed_proberefs;
Test::Weaken::Test::is(
Data::Dumper->Dump( [$unfreed], [qw(unfreed)] ),
<<'EOS',
$unfreed = [
\\\$unfreed->[0],
${$unfreed->[0]},
${${$unfreed->[0]}}
];
EOS
'cycle w/ copying ignore'
);
}
$restore = divert_stderr();
$eval_return = eval {
$tester = Test::Weaken::leaks(
{ constructor => sub { MyCycle->new() },
ignore => Test::Weaken::check_ignore( \©ing_ignore, 2 ),
}
);
};
$stderr = &{$restore};
if ( not $tester ) {
Test::More::pass('cycle w/ copying & error callback');
}
else {
my $unfreed = $tester->unfreed_proberefs;
Test::Weaken::Test::is(
Data::Dumper->Dump( [$unfreed], [qw(unfreed)] ),
<<'EOS',
$unfreed = [
\\\$unfreed->[0],
${$unfreed->[0]},
${${$unfreed->[0]}}
];
EOS
'unfreed refs for cycle w/ copying'
);
}
# the exact addresses will vary, so just X them out
$stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms;
$stderr .= $EVAL_ERROR if not $eval_return;
$stderr =~ s{
[ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $
}{ at <FILE> line <LINE_NUMBER>}gxms;
Test::Weaken::Test::is(
$stderr,
<<'EOS',
Probe referent strengthened by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
'stderr for cycle w/ copying'
);
sub cause_deep_problem {
my ($proberef) = @_;
if ( ref $proberef eq 'REF'
and Scalar::Util::reftype ${$proberef} eq 'HASH'
and exists ${$proberef}->{one} )
{
${$proberef}->{one}->{bad} = 42;
}
return 0;
}
my %counted_compare_depth_expected = (
0 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
1 => <<'EOS',
EOS
2 => <<'EOS',
EOS
3 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => 'HASH(0xXXXXXXX)'
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => 'HASH(0xXXXXXXX)'
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
4 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
);
sub counted_compare_depth {
my ($compare_depth) = @_;
$restore = divert_stderr();
$eval_return = eval {
Test::Weaken::leaks(
{ constructor => sub { DeepObject->new() },
ignore => Test::Weaken::check_ignore(
\&cause_deep_problem, 99,
$compare_depth, $compare_depth
),
}
);
};
$stderr = &{$restore};
# the exact addresses will vary, so just X them out
$stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms;
$stderr .= $EVAL_ERROR if not $eval_return;
$stderr =~ s{
[ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $
}{ at <FILE> line <LINE_NUMBER>}gxms;
Test::Weaken::Test::is(
$stderr,
$counted_compare_depth_expected{$compare_depth},
"deep problem, compare depth=$compare_depth"
);
return 1;
}
counted_compare_depth(0);
counted_compare_depth(1);
counted_compare_depth(2);
counted_compare_depth(3);
counted_compare_depth(4);
my %counted_reporting_depth_expected = (
0 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
1 => <<'EOS',
$proberef_before_callback = \'DeepObject=HASH(0xXXXXXXX)';
$proberef_after_callback = \'DeepObject=HASH(0xXXXXXXX)';
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
2 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => 'HASH(0xXXXXXXX)'
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => 'HASH(0xXXXXXXX)'
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
3 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => 'HASH(0xXXXXXXX)'
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => 'HASH(0xXXXXXXX)'
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
4 => <<'EOS',
$proberef_before_callback = \bless( {
'one' => {
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
$proberef_after_callback = \bless( {
'one' => {
'bad' => 42,
'two' => {
'three' => 4
}
}
}, 'DeepObject' );
Probe referent changed by ignore call
Above errors reported at <FILE> line <LINE_NUMBER>
EOS
);
sub counted_reporting_depth {
my ($reporting_depth) = @_;
$restore = divert_stderr();
$eval_return = eval {
## use Marpa::Test::Display check_ignore 4 arg snippet
$tester = Test::Weaken::leaks(
{ constructor => sub { DeepObject->new() },
ignore => Test::Weaken::check_ignore(
\&cause_deep_problem, 99, 0, $reporting_depth
),
}
);
## no Marpa::Test::Display
};
$stderr = &{$restore};
# the exact addresses will vary, so just X them out
$stderr =~ s/0x[0-9a-fA-F]*/0xXXXXXXX/gxms;
$stderr .= $EVAL_ERROR if not $eval_return;
$stderr =~ s{
[ ] at [ ] (\S+) [ ] line [ ] \d+ \.? $
}{ at <FILE> line <LINE_NUMBER>}gxms;
Test::Weaken::Test::is(
$stderr,
$counted_reporting_depth_expected{$reporting_depth},
"deep problem, reporting depth=$reporting_depth"
);
return 1;
}
counted_reporting_depth(0);
counted_reporting_depth(1);
counted_reporting_depth(2);
counted_reporting_depth(3);
counted_reporting_depth(4);