package IMPL::Profiler::Memory;

use strict;
use Carp qw(longmess shortmess);
use Scalar::Util qw(refaddr weaken isweak);

my %listeners;
my $trapped;

BEGIN {
	$trapped = 0;
}

sub import {
	if (not $trapped) {
	    *CORE::GLOBAL::bless = sub {
	        $_[1] |= caller unless $_[1];
	        my $ref = CORE::bless $_[0],$_[1];
	
	        $_->track($ref) foreach values %listeners;
	
	        return $ref;
	    };
	    $trapped = 1;
	}
}

sub _ConnectListener {
	my ($self,$listener) = @_;
	
	die "Invalid listener" unless ref $listener;
	
	$listeners{refaddr($listener)} = $listener;
}

sub _RemoveListener {
	my ($self,$listener) = @_;
	
	die "Invalid listener" unless ref $listener;
	
	delete $listeners{refaddr($listener)};
}

sub Monitor {
	my ($self,$code) = @_;
	
	my $data = IMPL::Profiler::Memory::Data->new();
	
	$data->Monitor($code);
	
	return $data; 
}

package IMPL::Profiler::Memory::Data;
use parent qw(IMPL::Object::Fields);

use Data::Dumper();
use Scalar::Util qw(refaddr weaken isweak);

use fields qw( objects );

sub CTOR {
	my $this = shift;
	$this->{objects} = [];
}

sub track {
	my $i = scalar @{$_[0]->{objects}};
	$_[0]->{objects}[$i] = $_[1];
	weaken($_[0]->{objects}[$i]);
}

sub Purge {
	my $this = shift;
	
	return $this->{objects} = [ grep defined($_), @{$this->{objects}}];
}

sub Dump {
	my $this = shift;
	return Data::Dumper->Dump([$this->{objects}]);
}

sub isLeak {
	my ($this) = @_;
	$this->Purge();
	return ( scalar(@{$this->{objects}}) > 0);
}

sub Monitor {
	my ($this,$code) = @_;
	
	die "A reference to a subroutine is required" unless ref $code;
	
	IMPL::Profiler::Memory->_ConnectListener($this);
	eval {
		$code->();
	};
	my $err = $@;
	IMPL::Profiler::Memory->_RemoveListener($this);
	
	die $err if $err;
	
	return;
}



1;