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