Devel::Events::Handler::ObjectTracker - A L<Devel::Events> that tracks leaks

Devel-Events-Objects documentation Contained in the Devel-Events-Objects distribution.

Index

Code Index:

NAME

Top

Devel::Events::Handler::ObjectTracker - A Devel::Events that tracks leaks

SYNOPSIS

Top

	use Devel::Events::Handler::ObjectTracker;
	use Devel::Events::Generator::Objects;

	my $tracker = Devel::Events::Handler::ObjectTracker->new();

	my $gen = Devel::Events::Generator::Objects->new(
		handler => $tracker,
	);

	$gen->enable(); # start generating events

	$code->();

	$gen->disable();

	use Data::Dumper;
	warn Dumper($tracker->live_objects);

DESCRIPTION

Top

This object will keep track of every object created and every object destroyed based on the object_bless and object_destroy events. Reblessing is accounted for.

This handler doesn't perform any magical stuff, Devel::Events::Generator::Objects is responsible for raising the proper events.

ATTRIBUTES

Top

live_objects

A Tie::RefHash::Weak hash that keeps an index of every live object and the object_bless event that created it.

class_counters

Keeps a count of the live instances per class, much like Devel::Leak::Object.

object_to_class

USed to maintain the class_counters hash.

METHODS

Top

new_event @event

Delegates to handle_object_bless or handle_object_destroy

handle_object_bless @event

Adds an entry in the live_objects table.

event_to_entry @event

Munges event data into an entry for the live_objects table.

handle_object_destroy

Decrements the class_counters counter.

Devel-Events-Objects documentation Contained in the Devel-Events-Objects distribution. 
#!/usr/bin/perl

package Devel::Events::Handler::ObjectTracker;
use Moose;

with qw/Devel::Events::Handler/;

use Scalar::Util qw/refaddr weaken/;
use Tie::RefHash::Weak;

has live_objects => (
	isa => "HashRef",
	is  => "ro",
	default => sub {
		tie my %hash, 'Tie::RefHash::Weak';
		\%hash;	
	},
);

has object_to_class => (
	isa => "HashRef",
	is  => "ro",
	default => sub { +{} },
);

has class_counters => (
	isa => "HashRef",
	is  => "ro",
	default => sub { +{} },
);

sub new_event {
	my ( $self, $type, @data ) = @_;

	if ( $self->can( my $method = "handle_$type" ) ) { # FIXME pattern match? i want erlang =)
		$self->$method( @data );
	}
}

sub handle_object_bless {
	my ( $self, %args ) = @_;

	return unless $args{tracked}; # don't keep track of objects that can't be garbage collected (shared code refs for instance)

	my $object = $args{object};
	my $class  = $args{class};

	my $class_counters = $self->class_counters;

	$class_counters->{$class}++;

	if ( defined(my $old_class = $args{old_class}) ) {
		# rebless
		$class_counters->{$old_class}--;
	} else {
		# new object
		my $entry = $self->event_to_entry( %args );
		( tied %{ $self->live_objects } )->STORE( $object, $entry ); # FIXME hash access triggers overload +0
	}

	# we need this because in object_destroy it's not blessed anymore
	#( tied %{ $self->object_to_class } )->STORE( $object, $class );
	$self->object_to_class->{refaddr($object)} = $class;
}

sub event_to_entry {
	my ( $self, %entry ) = @_;

	weaken($entry{object});

	return \%entry;
}

sub handle_object_destroy {
	my ( $self, %args ) = @_;
	
	my $object = $args{object};

	if ( defined( my $class = delete($self->object_to_class->{refaddr($object)}) ) ) {
		$self->class_counters->{$class}--;
	}
}

__PACKAGE__;

__END__