--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Lib/IMPL/Profiler/Memory.pm	Tue Jul 14 12:54:37 2009 +0400
@@ -0,0 +1,57 @@
+package IMPL::Profiler::Memory;
+
+use strict;
+use Carp qw(longmess shortmess);
+use Scalar::Util qw(refaddr weaken isweak);
+
+my %instances;
+
+BEGIN {
+    *CORE::GLOBAL::bless = sub {
+        $_[1] |= caller unless $_[1];
+        my $ref = CORE::bless $_[0],$_[1];
+
+        my $id = refaddr($ref);
+
+        $instances{$id} = {
+            Class => $_[1],
+            WeakRef => $ref
+        };
+
+        weaken($instances{$id}{WeakRef});
+
+        return $ref;
+    }
+}
+
+sub DumpAlive {
+    my ($hout) = @_;
+    $hout = *STDOUT unless $hout;
+    print $hout "Alive objects table\n";
+    print $hout "-------------------\n";
+    while (my ($id,$info) = each %instances) {
+        delete $instances{$id} and next unless $info->{WeakRef};
+        print "$info->{Class} $id: $info->{WeakRef}\n";
+    }
+}
+
+sub StatClasses {
+    my ($hout) = @_;
+    $hout = *STDOUT unless $hout;
+    print $hout "Statistics by class\n";
+    print $hout "-------------------\n";
+    my %stat;
+    while (my ($id,$info) = each %instances) {
+        #$stat{$info->{Class}}{total} ++;
+        delete $instances{$id} and next unless $info->{WeakRef};
+        $stat{$info->{Class}}{alive} ++;
+    }
+
+    print $hout "$_ $stat{$_}{alive} \n" foreach sort keys %stat;
+}
+
+sub Clear {
+    undef %instances;
+}
+
+1;
\ No newline at end of file