--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Profiler/Memory.pm	Fri Sep 04 19:40:23 2015 +0300
@@ -0,0 +1,111 @@
+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;