Devel::TrackObjects - Track use of objects

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

our $VERSION = 0.4;

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


############################################################################
# redefined CORE::GLOBAL::bless if restrictions are given
# which classes should get tracked
############################################################################
sub import {
	shift;
	my @opt;
	while (@_) {
		local $_ = shift;
		if ( ! ref && m{^-(\w+)$} ) {
			push @opt,$1;
		} elsif ( $_ eq 'track_object' ) {
			# export function
			my ($pkg) = caller();
			no strict 'refs';
			*{"${pkg}::track_object"} = \&track_object;
		} elsif ( ! ref && m{^/} ) {
			# assume uncompiled regex
			my $rx = eval "qr$_";
			die $@ if $@;
			push @conditions,$rx;
		} else {
			push @conditions,$_
		}
	}
	for(@opt) {
		if ( $_ eq 'debug' ) {
			$debug = 1;
		} elsif ( $_ eq 'verbose' ) {
			$verbose = 1;
		} elsif ( $_ eq 'timestamp' ) {
			$with_tstamp = 1;
		} elsif ( $_ eq 'noend' ) {
			$no_end = 1;
		} elsif ( $_ eq 'size' ) {
			# need Devel::Size;
			$with_size = eval { require Devel::Size }
				or die "need Devel::Size installed for '-size' option"
		} elsif ( $_ eq 'sizediff' ) {
			$with_sizediff = 1;
			push @opt,'size' if ! $with_size;
		} else {
			die "unknown option $_";
		}
	}
	_redefine_bless() if @conditions;
}

############################################################################
# show everything tracked at the end
############################################################################
sub END {
	$no_end && return;
	__PACKAGE__->show_tracked() if $is_redefined;
	1;
}


############################################################################
# depending on $verbose show detailed or compact version
############################################################################
sub show_tracked {
	return $verbose
		? show_tracked_detailed(@_)
		: show_tracked_compact(@_);
}

############################################################################
# show what's still used. If I want something back give reference to
# \@weak_objects, else print myself to STDERR
############################################################################
sub show_tracked_detailed {
	shift;
	my $prefix = shift || '';
	_remove_destroyed();
	if ( defined wantarray ) {
		return \@weak_objects;
	} else {
		if ( @weak_objects ) {
			my (%s,%l);
			print STDERR "LEAK$prefix "
				. ($with_tstamp ? localtime().' ' :'' ) . " >> \n";
			for my $o ( sort { $a->[0] cmp $b->[0] } @weak_objects ) {
				my $line = '-- ';
				if ( $with_size ) {
					my $size = Devel::Size::size($o->[0]);
					my $total_size = Devel::Size::total_size($o->[0]);
					if ( $with_sizediff ) {
						$line .= sprintf("size=%d/%+d/%+d ",$size,
							$size-($o->[6]||0),$size-($o->[4]||0));
						$line .= sprintf("%d/%+d/%+d ", $total_size,
							$total_size-($o->[7]||0),$total_size-($o->[5]||0));
						$o->[4] = $size if ! defined $o->[4];
						$o->[5] = $total_size if ! defined $o->[5];
						$o->[6] = $size;
						$o->[7] = $total_size;
					} else {
						$line .= "size=$size total=$total_size ";
					}
				}
				$line .= sprintf "%s | %s:%s%s\n", "$o->[0]",$o->[1],$o->[2],
					defined($o->[3]) ? " $o->[3]":'';
				print STDERR $line;
			}
			print STDERR "LEAK$prefix --\n";
		} else {
			print STDERR "LEAK$prefix "
				. ($with_tstamp ? localtime().' ' :'' ) . " >> empty --\n";
		}
	}
}

############################################################################
# show tracked objects in compact form, e.g. only counter for each class
############################################################################
sub show_tracked_compact {
	shift;
	my $prefix = shift || '';
	_remove_destroyed();
	my %count4class;
	foreach my $o (@weak_objects) {
		( $count4class{ ref($o->[0]) } ||= 0 )++;
	}
	if ( defined wantarray ) {
		return %count4class ? \%count4class : undef
	}

	my $msg = "LEAK$prefix >> ";
	if ( %count4class ) {
		foreach ( sort keys %count4class ) {
			$msg .= $_.'='.$count4class{$_}.' ';
		}
	} else {
		$msg .= "empty "
	}
	$msg .= "--\n";
	print STDERR $msg;
}

############################################################################
# bless object and track it, if it matches @condition
############################################################################
sub _bless_and_track($;$) {
	my ($pkg,$filename,$line) = caller();
	my $class = $_[1] || $pkg;
	my $object = $old_bless ? $old_bless->( $_[0],$class) : CORE::bless( $_[0],$class );

	my $track = 0;
	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 @_\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__