view release on metacpan or  search on metacpan

lib/Devel/TrackObjects.pm  view on Meta::CPAN

package Devel::TrackObjects;
use strict;
use warnings;
use Scalar::Util 'weaken';
use overload;

our $VERSION = '0.601';

my @weak_objects; # List of weak objects incl file + line
my @conditions;   # which objects to track, set by import
my $is_redefined; # flag if already redefined
my $old_bless;    # bless sub before redefining

my $debug;        # enable internal debugging
my $verbose;      # detailed output instead of compact
my $with_tstamp;  # prefix output with timestamp
my $with_size;    # with size of objects
my $with_sizediff; # track changes in size
my $no_end;       # no show tracked at END


my $outfunc = sub {
    my ($prefix,$out) = @_;
    if (ref($out)) {
	# details - can be multiple lines
	if (@$out) {
	    print STDERR "LEAK$prefix " .
		($with_tstamp ? localtime().' ' :'' ) . " >> \n",
		@$out,
		" --\n";
	} else {
	    print STDERR "LEAK$prefix " .
		($with_tstamp ? localtime().' ' :'' ) . " >> empty --\n";
	}
    } else {
	# no details - single line
	$out ||= 'empty ';
	print STDERR "LEAK$prefix >> $out--\n";
    }
};


############################################################################
# redefined CORE::GLOBAL::bless if restrictions are given
# which classes should get tracked
############################################################################
sub import {
    shift;
    while (@_) {
	local $_ = shift;
	if ( ! ref && m{^-(\w+)$} ) {
	    if ($1 eq 'debug') {
		$debug = 1;
	    } elsif ($1 eq 'verbose') {
		$verbose = 1;
	    } elsif ($1 eq 'timestamp') {
		$with_tstamp = 1;
	    } elsif ($1 eq 'noend') {
		$no_end = 1;
	    } elsif ($1 eq 'size') {
		# need Devel::Size;
		$with_size = eval { require Devel::Size }
		    or die "need Devel::Size installed for '-size' option"
	    } elsif ($1 eq 'sizediff') {

lib/Devel/TrackObjects.pm  view on Meta::CPAN

    if ( @conditions ) {
	foreach my $c ( @conditions ) {
	    if ( ! ref($c) ) {
		$track = 1,last if $c eq $pkg or $c eq $class;
	    } elsif ( UNIVERSAL::isa($c,'Regexp' )) {
		$track = 1,last if $pkg =~m{$c} or $class =~m{$c};
	    } elsif ( UNIVERSAL::isa($c,'CODE' )) {
		$track = 1,last if $c->($pkg) or $c->($class);
	    }
	}
    } else {
	$track = 1;
    }
    _register( $object,$filename,$line ) if $track;

    return $object;
}

############################################################################
sub track_object {
    my ($object,$info) = @_;
    my (undef,$filename,$line) = caller();
    _register( $object,$filename,$line,$info );
}

############################################################################
# redefine bless unless it's already redefined
############################################################################
sub _redefine_bless {
    return if $is_redefined;

    # take redefined variant if exists
    $old_bless = \&CORE::CLOBAL::bless;
    eval { $old_bless->( {}, __PACKAGE__ ) };
    $old_bless = undef if $@;

    # redefine 'bless'
    no warnings 'once';
    *CORE::GLOBAL::bless = \&_bless_and_track;
    $is_redefined = 1;
}


############################################################################
# register object, called from _bless_and_track
############################################################################
sub _register {
    my ($ref,$fname,$line,$info) = @_;
    warn "TrackObjects: register ".overload::StrVal($ref).
	" $fname:$line ".(defined($info) ? $info:'' )."\n"
	if $debug;
    #0: referenz
    #1: file name
    #2: line in file
    #3: info message
    #4: initial size
    #5: initial total_size
    #6: last size
    #7: last total_size
    push @weak_objects, [ $ref,$fname,$line,$info ];
    weaken( $weak_objects[-1][0] );
}

############################################################################
# eliminate destroyed objects, eg where the weak ref is undef
############################################################################
sub _remove_destroyed {
    @weak_objects = grep { defined( $_->[0] ) } @weak_objects;
}


1;

__END__

=head1 NAME

Devel::TrackObjects - Track use of objects

=head1 SYNOPSIS

=over 4

=item cmdline

 perl -MDevel::TrackObjects=/^IO::/ server.pl

=item inside

 use Devel::TrackObjects qr/^IO::/;
 use Devel::TrackObjects '-verbose','track_object';
 use Devel::TrackObjects '-size','-sizediff','-timestamp';
 use IO::Socket;
 ...
 my $sock = IO::Socket::INET->new...
 ...
 my $foreign = get_some_object_from_xs();
 track_object( $foreign, "This was created in XS" );
 ...
 Devel::TrackObjects->show_tracked;

=back

=head1 DESCRIPTION

Devel::TrackObjects redefines C<bless> and thus tracks
the creation of objects by putting weak references to the
object into a list. It can be specified which classes
to track.

At the end of the program it will print out infos about the
still existing objects (probably leaking). The same info
can be print out during the run using L<show_tracked>.

=head1 IMPORTANT

The Module must be loaded as early as possible, because it
cannot redefine B<bless> in already loaded modules. See L<import>
how to load it so that it redefines B<bless>.

=head1 METHODS