Devel-Events-Objects

 view release on metacpan or  search on metacpan

lib/Devel/Events/Generator/Objects.pm  view on Meta::CPAN

	$class = caller(1) unless defined $class;
	CORE::bless($data, $class);
}

use Moose;

with qw/Devel::Events::Generator/;

use Carp qw/croak/;
use Variable::Magic qw/cast getdata/;
use Scalar::Util qw/reftype blessed weaken/;

use B qw/svref_2object CVf_CLONED/;

{
	no warnings 'redefine';

    # for some reason this breaks at compile time
    # we need this version to preserve errors though
	# hopefully no bad calls to bless() are made during the loading of Moose

lib/Devel/Events/Generator/Objects.pm  view on Meta::CPAN

			$e =~ s/ at $file line $line\.\n$//o;

			croak($e);
		}
	};
}

sub enable {
	my $self = shift;
	$SINGLETON = $self;
	weaken($SINGLETON);
}

sub disable {
	$SINGLETON = undef;
}

sub bless {
	my ( $self, $data, $class ) = @_;
	$class = caller(1) unless defined $class;

lib/Devel/Events/Generator/Objects.pm  view on Meta::CPAN

		} else {
			$objects = getdata ( &$object, $wiz )
				or cast( &$object, $wiz, ( $objects = [] ) );
		}
	} else {
		die "patches welcome";
	}

	unless ( grep { $_ eq $self } @$objects ) {
		push @$objects, $self;
		weaken($objects->[-1]);
	}

	return 1;
}

sub untrack_object {
	my ( $self, $object );

	return;
}

lib/Devel/Events/Handler/ObjectTracker.pm  view on Meta::CPAN

#!/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;	
	},
);

lib/Devel/Events/Handler/ObjectTracker.pm  view on Meta::CPAN

	}

	# 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)}) ) ) {

t/031_handler_objecttracker.t  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;

use Test::More 'no_plan';

use Scalar::Util qw/weaken/;

my $m; use ok $m = "Devel::Events::Handler::ObjectTracker";

use Devel::Events::Generator::Objects;
use Devel::Events::Filter::RemoveFields;

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

{
	my $gen = Devel::Events::Generator::Objects->new(

t/031_handler_objecttracker.t  view on Meta::CPAN

	{
		my $object = bless({}, "Class::A");

		$object->{self} = $object;
	}

	{
		my $object = bless({}, "Class::B");
		$object->{foo}{bar}{gorch} = $object;

		weaken($object->{foo}{bar}{gorch});
	}

	{
		my $circ;
		my $object = bless(sub { $circ }, "Class::C");
		$circ = $object;
	}

	{
		my $object = bless(sub { }, "Class::D"); # it leaks but we can't help it
	}

	{
		my $circ;
		my $object = bless(sub { $circ }, "Class::E");
		$circ = $object;
		weaken($circ);
	}

	$gen->disable();

}

# sort by class
my @leaked = sort { ref($a) cmp ref($b) } keys %{ $tracker->live_objects };

is( scalar(@leaked), 2, "two leaked objects" );