49
+ − 1 package IMPL::Profiler::Memory;
+ − 2
+ − 3 use strict;
+ − 4 use Carp qw(longmess shortmess);
+ − 5 use Scalar::Util qw(refaddr weaken isweak);
+ − 6
+ − 7 my %instances;
+ − 8
+ − 9 BEGIN {
+ − 10 *CORE::GLOBAL::bless = sub {
+ − 11 $_[1] |= caller unless $_[1];
+ − 12 my $ref = CORE::bless $_[0],$_[1];
+ − 13
+ − 14 my $id = refaddr($ref);
+ − 15
+ − 16 $instances{$id} = {
+ − 17 Class => $_[1],
+ − 18 WeakRef => $ref
+ − 19 };
+ − 20
+ − 21 weaken($instances{$id}{WeakRef});
+ − 22
+ − 23 return $ref;
+ − 24 }
+ − 25 }
+ − 26
+ − 27 sub DumpAlive {
+ − 28 my ($hout) = @_;
+ − 29 $hout = *STDOUT unless $hout;
+ − 30 print $hout "Alive objects table\n";
+ − 31 print $hout "-------------------\n";
+ − 32 while (my ($id,$info) = each %instances) {
+ − 33 delete $instances{$id} and next unless $info->{WeakRef};
+ − 34 print "$info->{Class} $id: $info->{WeakRef}\n";
+ − 35 }
+ − 36 }
+ − 37
+ − 38 sub StatClasses {
+ − 39 my ($hout) = @_;
+ − 40 $hout = *STDOUT unless $hout;
+ − 41 print $hout "Statistics by class\n";
+ − 42 print $hout "-------------------\n";
+ − 43 my %stat;
+ − 44 while (my ($id,$info) = each %instances) {
+ − 45 #$stat{$info->{Class}}{total} ++;
+ − 46 delete $instances{$id} and next unless $info->{WeakRef};
+ − 47 $stat{$info->{Class}}{alive} ++;
+ − 48 }
+ − 49
+ − 50 print $hout "$_ $stat{$_}{alive} \n" foreach sort keys %stat;
+ − 51 }
+ − 52
+ − 53 sub Clear {
+ − 54 undef %instances;
+ − 55 }
+ − 56
+ − 57 1;