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 counter);

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

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

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;