File Coverage

blib/lib/Test/Weaken.pm

Criterion	Covered	Total	%
statement	294	330	89.0
branch	139	176	78.9
condition	16	21	76.1
subroutine	22	22	100.0
pod	8	10	80.0
total	479	559	85.6

package Test::Weaken;


# maybe:
# contents_funcs => arrayref of funcs
#     multiple contents, or sub{} returning list enough ?
# track_filehandles => 1  GLOB and IO
#
# locations=>1
#  top->{'foo'}->[10]->REF->*{IO}
#  top.H{'foo'}.A[10].REF.*{IO}
# unfreed_locations() arrayref of strings
# first location encountered
# locations_maxdepth


use 5.006;
use strict;
use warnings;

require Exporter;

use base qw(Exporter);
our @EXPORT_OK = qw(leaks poof);
our $VERSION   = '3.022000';

#use Smart::Comments;

###  Using Smart Comments ...

=begin Implementation:

The basic strategy: get a list of all the objects which allocate memory,
create probe references to them, weaken those probe references, attempt
to free the memory, and check the references.  If the memory is free,
the probe references will be undefined.

Probe references also serve a second purpose -- to avoid copying any
weak reference in the original object.  When you copy a weak reference,
the result is a strong reference.

There may be good reasons for Perl strengthen-on-copy policy, but that
behavior is a big problem for this module.  A lot of what might seem
like needless indirection in the code below is done to avoid working
with references directly in situations which could involve making a copy
of them, even implicitly.

=end Implementation:

=cut

package Test::Weaken::Internal;

use English qw( -no_match_vars );
use Carp;
use Scalar::Util 1.18 qw();

my @default_tracked_types = qw(REF SCALAR VSTRING HASH ARRAY CODE);

sub follow {
    my ( $self, @base_probe_list ) = @_;

    my $ignore_preds       = $self->{ignore_preds};
    my $contents           = $self->{contents};
    my $trace_maxdepth     = $self->{trace_maxdepth};
    my $trace_following    = $self->{trace_following};
    my $trace_tracking     = $self->{trace_tracking};
    my $user_tracked_types = $self->{tracked_types};

    my @tracked_types = @default_tracked_types;
    if ( defined $user_tracked_types ) {
        push @tracked_types, @{$user_tracked_types};
    }
    my %tracked_type = map { ( $_, 1 ) } @tracked_types;

    defined $trace_maxdepth or $trace_maxdepth = 0;

    # Initialize the results with a reference to the dereferenced
    # base reference.

    # The initialization assumes each $base_probe is a reference,
    # not part of the test object, whose referent is also a reference
    # which IS part of the test object.
    my @follow_probes    = @base_probe_list;
    my @tracking_probes  = @base_probe_list;
    my %already_followed = ();
    my %already_tracked  = ();

    FOLLOW_OBJECT:
    while ( defined( my $follow_probe = pop @follow_probes ) ) {

        # The follow probes are to objects which either will not be
        # tracked or which have already been added to @tracking_probes

        next FOLLOW_OBJECT
            if $already_followed{ Scalar::Util::refaddr $follow_probe }++;

        my $object_type = Scalar::Util::reftype $follow_probe;

        my @child_probes = ();

        if ($trace_following) {
            require Data::Dumper;
            ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
            print {*STDERR} 'Following: ',
                Data::Dumper->new( [$follow_probe], [qw(tracking)] )->Terse(1)
                ->Maxdepth($trace_maxdepth)->Dump
                or Carp::croak("Cannot print to STDOUT: $ERRNO");
            ## use critic
        } ## end if ($trace_following)

        if ( defined $contents ) {
            my $safe_copy = $follow_probe;
            push @child_probes, map { \$_ } ( $contents->($safe_copy) );
        }

        FIND_CHILDREN: {

            foreach my $ignore (@$ignore_preds) {
                my $safe_copy = $follow_probe;
                last FIND_CHILDREN if $ignore->($safe_copy);
            }

            if ( $object_type eq 'ARRAY' ) {
                if ( my $tied_var = tied @{$follow_probe} ) {
                    push @child_probes, \($tied_var);
                }
                foreach my $i ( 0 .. $#{$follow_probe} ) {
                    if ( exists $follow_probe->[$i] ) {
                        push @child_probes, \( $follow_probe->[$i] );
                    }
                }
                last FIND_CHILDREN;
            } ## end if ( $object_type eq 'ARRAY' )

            if ( $object_type eq 'HASH' ) {
                if ( my $tied_var = tied %{$follow_probe} ) {
                    push @child_probes, \($tied_var);
                }
                push @child_probes, map { \$_ } values %{$follow_probe};
                last FIND_CHILDREN;
            } ## end if ( $object_type eq 'HASH' )

            # GLOB is not tracked by default,
            # but we follow ties
            if ( $object_type eq 'GLOB' ) {
                if ( my $tied_var = tied *${$follow_probe} ) {
                    push @child_probes, \($tied_var);
                }
                last FIND_CHILDREN;
            } ## end if ( $object_type eq 'GLOB' )

            # LVALUE is not tracked by default,
            # but we follow ties
            if (   $object_type eq 'SCALAR'
                or $object_type eq 'VSTRING'
                or $object_type eq 'LVALUE' )
            {
                if ( my $tied_var = tied ${$follow_probe} ) {
                    push @child_probes, \($tied_var);
                }
                last FIND_CHILDREN;
            } ## end if ( $object_type eq 'SCALAR' or $object_type eq ...)

            if ( $object_type eq 'REF' ) {
                if ( my $tied_var = tied ${$follow_probe} ) {
                    push @child_probes, \($tied_var);
                }
                push @child_probes, ${$follow_probe};
                last FIND_CHILDREN;
            } ## end if ( $object_type eq 'REF' )

        } ## end FIND_CHILDREN:

        push @follow_probes, @child_probes;

        CHILD_PROBE: for my $child_probe (@child_probes) {

            my $child_type = Scalar::Util::reftype $child_probe;

            next CHILD_PROBE unless $tracked_type{$child_type};

            my $new_tracking_probe = $child_probe;

            next CHILD_PROBE
                if $already_tracked{ Scalar::Util::refaddr $new_tracking_probe
                    }++;

            foreach my $ignore (@$ignore_preds) {
                my $safe_copy = $new_tracking_probe;
                next CHILD_PROBE if $ignore->($safe_copy);
            }

            if ($trace_tracking) {
                ## no critic (ValuesAndExpressions::ProhibitLongChainsOfMethodCalls)
                print {*STDERR} 'Tracking: ',
                    Data::Dumper->new( [$new_tracking_probe], [qw(tracking)] )
                    ->Terse(1)->Maxdepth($trace_maxdepth)->Dump
                    or Carp::croak("Cannot print to STDOUT: $ERRNO");
                ## use critic

                 # print {*STDERR} 'Tracking: ',
                 #   "$new_tracking_probe\n";

            } ## end if ($trace_tracking)
            push @tracking_probes, $new_tracking_probe;

        } ## end for my $child_probe (@child_probes)

    }    # FOLLOW_OBJECT

    return \@tracking_probes;

}    # sub follow

# See POD, below
sub Test::Weaken::new {
    my ( $class, $arg1, $arg2 ) = @_;
    my $self = {};
    bless $self, $class;
    $self->{test} = 1;

    my @ignore_preds;
    my @ignore_classes;
    my @ignore_objects;
    $self->{ignore_preds} = \@ignore_preds;

  UNPACK_ARGS: {
        if ( ref $arg1 eq 'CODE' ) {
            $self->{constructor} = $arg1;
            if ( defined $arg2 ) {
                $self->{destructor} = $arg2;
            }
            return $self;
        }

        if ( ref $arg1 ne 'HASH' ) {
            Carp::croak('arg to Test::Weaken::new is not HASH ref');
        }

        if (defined (my $constructor = delete $arg1->{constructor})) {
            $self->{constructor} = $constructor;
        }

        if (defined (my $destructor = delete $arg1->{destructor})) {
            $self->{destructor} = $destructor;
        }
        if (defined (my $destructor_method = delete $arg1->{destructor_method})) {
            $self->{destructor_method} = $destructor_method;
        }

        if (defined (my $coderef = delete $arg1->{ignore})) {
            if (ref $coderef ne 'CODE') {
                Carp::croak('Test::Weaken: ignore must be CODE ref');
            }
            push @ignore_preds, $coderef;
        }
        if (defined (my $ignore_preds = delete $arg1->{ignore_preds})) {
            push @ignore_preds, @$ignore_preds;
        }
        if ( defined (my $ignore_class = delete $arg1->{ignore_class} )) {
            push @ignore_classes, $ignore_class;
        }
        if ( defined (my $ignore_classes = delete $arg1->{ignore_classes} )) {
            push @ignore_classes, @$ignore_classes;
        }
        push @ignore_objects, delete $arg1->{ignore_object};
        if ( defined (my $ignore_objects = delete $arg1->{ignore_objects} )) {
            push @ignore_objects, @$ignore_objects;
        }

        if ( defined $arg1->{trace_maxdepth} ) {
            $self->{trace_maxdepth} = $arg1->{trace_maxdepth};
            delete $arg1->{trace_maxdepth};
        }

        if ( defined $arg1->{trace_following} ) {
            $self->{trace_following} = $arg1->{trace_following};
            delete $arg1->{trace_following};
        }

        if ( defined $arg1->{trace_tracking} ) {
            $self->{trace_tracking} = $arg1->{trace_tracking};
            delete $arg1->{trace_tracking};
        }

        if ( defined $arg1->{contents} ) {
            $self->{contents} = $arg1->{contents};
            delete $arg1->{contents};
        }

        if ( defined $arg1->{test} ) {
            $self->{test} = $arg1->{test};
            delete $arg1->{test};
        }

        if ( defined $arg1->{tracked_types} ) {
            $self->{tracked_types} = $arg1->{tracked_types};
            delete $arg1->{tracked_types};
        }

        my @unknown_named_args = keys %{$arg1};

        if (@unknown_named_args) {
            my $message = q{};
            for my $unknown_named_arg (@unknown_named_args) {
                $message .= "Unknown named arg: '$unknown_named_arg'\n";
            }
            Carp::croak( $message
                         . 'Test::Weaken failed due to unknown named arg(s)' );
        }

    }    # UNPACK_ARGS

    if ( my $ref_type = ref $self->{constructor} ) {
        Carp::croak('Test::Weaken: constructor must be CODE ref')
            unless ref $self->{constructor} eq 'CODE';
    }

    if ( my $ref_type = ref $self->{destructor} ) {
        Carp::croak('Test::Weaken: destructor must be CODE ref')
            unless ref $self->{destructor} eq 'CODE';
    }

    if ( my $ref_type = ref $self->{contents} ) {
        Carp::croak('Test::Weaken: contents must be CODE ref')
            unless ref $self->{contents} eq 'CODE';
    }

    if ( my $ref_type = ref $self->{tracked_types} ) {
        Carp::croak('Test::Weaken: tracked_types must be ARRAY ref')
            unless ref $self->{tracked_types} eq 'ARRAY';
    }

    if (@ignore_classes) {
        push @ignore_preds, sub {
            my ($ref) = @_;
            if (Scalar::Util::blessed($ref)) {
                foreach my $class (@ignore_classes) {
                    if ($ref->isa($class)) {
                        return 1;
                    }
                }
            }
            return 0;
        };
    }

    # undefs in ignore objects are skipped
    @ignore_objects = grep {defined} @ignore_objects;
    if (@ignore_objects) {
        push @ignore_preds, sub {
            my ($ref) = @_;
            $ref = Scalar::Util::refaddr($ref);
            foreach my $object (@ignore_objects) {
                if (Scalar::Util::refaddr($object) == $ref) {
                    return 1;
                }
            }
            return 0;
        };
    }

    return $self;

}    # sub new

sub Test::Weaken::test {

    my $self = shift;

    if ( defined $self->{unfreed_probes} ) {
        Carp::croak('Test::Weaken tester was already evaluated');
    }

    my $constructor = $self->{constructor};
    my $destructor  = $self->{destructor};
    # my $ignore      = $self->{ignore};
    my $contents    = $self->{contents};
    my $test        = $self->{test};

    my @test_object_probe_list = map {\$_} $constructor->();
    foreach my $test_object_probe (@test_object_probe_list) {
        if ( not ref ${$test_object_probe} ) {
            Carp::carp(
              'Test::Weaken test object constructor returned a non-reference'
            );
        }
    }
    my $probes = Test::Weaken::Internal::follow( $self, @test_object_probe_list );

    $self->{probe_count} = @{$probes};
    $self->{weak_probe_count} =
        grep { ref $_ eq 'REF' and Scalar::Util::isweak ${$_} } @{$probes};
    $self->{strong_probe_count} =
        $self->{probe_count} - $self->{weak_probe_count};

    if ( not $test ) {
        $self->{unfreed_probes} = $probes;
        return scalar @{$probes};
    }

    for my $probe ( @{$probes} ) {
        Scalar::Util::weaken($probe);
    }

    # Now free everything.
    if (defined (my $destructor_method = $self->{destructor_method})) {
        foreach my $test_object_probe (@test_object_probe_list) {
            my $obj = $$test_object_probe;
            $obj->$destructor_method;
        }
    }
    if (defined $destructor) {
        $destructor->( map {$$_} @test_object_probe_list ) ;
    }

    @test_object_probe_list = ();

    my $unfreed_probes = [ grep { defined $_ } @{$probes} ];
    $self->{unfreed_probes} = $unfreed_probes;

    return scalar @{$unfreed_probes};

}    # sub test

# Undocumented and deprecated
sub poof_array_return {

    my $tester  = shift;
    my $results = $tester->{unfreed_probes};

    my @unfreed_strong = ();
    my @unfreed_weak   = ();
    for my $probe ( @{$results} ) {
        if ( ref $probe eq 'REF' and Scalar::Util::isweak ${$probe} ) {
            push @unfreed_weak, $probe;
        }
        else {
            push @unfreed_strong, $probe;
        }
    }

    return (
        $tester->weak_probe_count(),
        $tester->strong_probe_count(),
        \@unfreed_weak, \@unfreed_strong
    );

} ## end sub poof_array_return;

sub Test::Weaken::poof {
    my @args   = @_;
    my $tester = Test::Weaken->new(@args);
    my $result = $tester->test();
    return Test::Weaken::Internal::poof_array_return($tester) if wantarray;
    return $result;
}

sub Test::Weaken::leaks {
    my @args   = @_;
    my $tester = Test::Weaken->new(@args);
    my $result = $tester->test();
    return $tester if $result;
    return;
}

sub Test::Weaken::unfreed_proberefs {
    my $tester = shift;
    my $result = $tester->{unfreed_probes};
    if ( not defined $result ) {
        Carp::croak('Results not available for this Test::Weaken object');
    }
    return $result;
}

sub Test::Weaken::unfreed_count {
    my $tester = shift;
    my $result = $tester->{unfreed_probes};
    if ( not defined $result ) {
        Carp::croak('Results not available for this Test::Weaken object');
    }
    return scalar @{$result};
}

sub Test::Weaken::probe_count {
    my $tester = shift;
    my $count  = $tester->{probe_count};
    if ( not defined $count ) {
        Carp::croak('Results not available for this Test::Weaken object');
    }
    return $count;
}

# Undocumented and deprecated
sub Test::Weaken::weak_probe_count {
    my $tester = shift;
    my $count  = $tester->{weak_probe_count};
    if ( not defined $count ) {
        Carp::croak('Results not available for this Test::Weaken object');
    }
    return $count;
}

# Undocumented and deprecated
sub Test::Weaken::strong_probe_count {
    my $tester = shift;
    my $count  = $tester->{strong_probe_count};
    if ( not defined $count ) {
        Carp::croak('Results not available for this Test::Weaken object');
    }
    return $count;
}

sub Test::Weaken::check_ignore {
    my ( $ignore, $max_errors, $compare_depth, $reporting_depth ) = @_;

    my $error_count = 0;

    $max_errors = 1 if not defined $max_errors;
    if ( not Scalar::Util::looks_like_number($max_errors) ) {
        Carp::croak('Test::Weaken::check_ignore max_errors must be a number');
    }
    $max_errors = 0 if $max_errors <= 0;

    $reporting_depth = -1 if not defined $reporting_depth;
    if ( not Scalar::Util::looks_like_number($reporting_depth) ) {
        Carp::croak(
            'Test::Weaken::check_ignore reporting_depth must be a number');
    }
    $reporting_depth = -1 if $reporting_depth < 0;

    $compare_depth = 0 if not defined $compare_depth;
    if ( not Scalar::Util::looks_like_number($compare_depth)
        or $compare_depth < 0 )
    {
        Carp::croak(
            'Test::Weaken::check_ignore compare_depth must be a non-negative number'
        );
    }

    return sub {
        my ($probe_ref) = @_;

        my $array_context = wantarray;

        my $before_weak =
            ( ref $probe_ref eq 'REF'
                and Scalar::Util::isweak( ${$probe_ref} ) );
        my $before_dump =
            Data::Dumper->new( [$probe_ref], [qw(proberef)] )
            ->Maxdepth($compare_depth)->Dump();
        my $before_reporting_dump;
        if ( $reporting_depth >= 0 ) {
            #<<< perltidy doesn't do this well
            $before_reporting_dump =
                Data::Dumper->new(
                    [$probe_ref],
                    [qw(proberef_before_callback)]
                )
                ->Maxdepth($reporting_depth)
                ->Dump();
            #>>>
        }

        my $scalar_return_value;
        my @array_return_value;
        if ($array_context) {
            @array_return_value = $ignore->($probe_ref);
        }
        else {
            $scalar_return_value = $ignore->($probe_ref);
        }

        my $after_weak =
            ( ref $probe_ref eq 'REF'
                and Scalar::Util::isweak( ${$probe_ref} ) );
        my $after_dump =
            Data::Dumper->new( [$probe_ref], [qw(proberef)] )
            ->Maxdepth($compare_depth)->Dump();
        my $after_reporting_dump;
        if ( $reporting_depth >= 0 ) {
            #<<< perltidy doesn't do this well
            $after_reporting_dump =
                Data::Dumper->new(
                    [$probe_ref],
                    [qw(proberef_after_callback)]
                )
                ->Maxdepth($reporting_depth)
                ->Dump();
            #<<<
        }

        my $problems       = q{};
        my $include_before = 0;
        my $include_after  = 0;

        if ( $before_weak != $after_weak ) {
            my $changed = $before_weak ? 'strengthened' : 'weakened';
            $problems .= "Probe referent $changed by ignore call\n";
            $include_before = defined $before_reporting_dump;
        }
        if ( $before_dump ne $after_dump ) {
            $problems .= "Probe referent changed by ignore call\n";
            $include_before = defined $before_reporting_dump;
            $include_after  = defined $after_reporting_dump;
        }

        if ($problems) {

            $error_count++;

            my $message = q{};
            $message .= $before_reporting_dump
                if $include_before;
            $message .= $after_reporting_dump
                if $include_after;
            $message .= $problems;

            if ( $max_errors > 0 and $error_count >= $max_errors ) {
                $message
                    .= "Terminating ignore callbacks after finding $error_count error(s)";
                Carp::croak($message);
            }

            Carp::carp( $message . 'Above errors reported' );

        }

        return $array_context ? @array_return_value : $scalar_return_value;

    };
}

1;

__END__