annotate Lib/IMPL/Profiler/Memory.pm @ 17:7f88e01b58f8

dom
author Sergey
date Wed, 09 Sep 2009 17:43:31 +0400
parents 03e58a454b20
children 16ada169ca75
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
1 package IMPL::Profiler::Memory;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
2
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
3 use strict;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
4 use Carp qw(longmess shortmess);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
5 use Scalar::Util qw(refaddr weaken isweak);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
6
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
7 my %instances;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
8
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
9 BEGIN {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
10 *CORE::GLOBAL::bless = sub {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
11 $_[1] |= caller unless $_[1];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
12 my $ref = CORE::bless $_[0],$_[1];
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
13
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
14 my $id = refaddr($ref);
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
15
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
16 $instances{$id} = {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
17 Class => $_[1],
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
18 WeakRef => $ref
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
19 };
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
20
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
21 weaken($instances{$id}{WeakRef});
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
22
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
23 return $ref;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
24 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
25 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
26
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
27 sub DumpAlive {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
28 my ($hout) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
29 $hout = *STDOUT unless $hout;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
30 print $hout "Alive objects table\n";
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
31 print $hout "-------------------\n";
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
32 while (my ($id,$info) = each %instances) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
33 delete $instances{$id} and next unless $info->{WeakRef};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
34 print "$info->{Class} $id: $info->{WeakRef}\n";
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
35 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
36 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
37
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
38 sub StatClasses {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
39 my ($hout) = @_;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
40 $hout = *STDOUT unless $hout;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
41 print $hout "Statistics by class\n";
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
42 print $hout "-------------------\n";
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
43 my %stat;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
44 while (my ($id,$info) = each %instances) {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
45 #$stat{$info->{Class}}{total} ++;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
46 delete $instances{$id} and next unless $info->{WeakRef};
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
47 $stat{$info->{Class}}{alive} ++;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
48 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
49
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
50 print $hout "$_ $stat{$_}{alive} \n" foreach sort keys %stat;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
51 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
52
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
53 sub Clear {
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
54 undef %instances;
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
55 }
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
56
03e58a454b20 Создан репозитарий
Sergey
parents:
diff changeset
57 1;