Mercurial > pub > Impl

comparison Lib/IMPL/Profiler/Memory.pm @ 188:029c9610528c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Memory leak tests in IMPL::Web::View
author cin
date Tue, 03 Apr 2012 20:08:42 +0400
parents 16ada169ca75
children 08015e2803f1
comparison
equal deleted inserted replaced
187:927653d01f4f 188:029c9610528c
2 2
3 use strict; 3 use strict;
4 use Carp qw(longmess shortmess); 4 use Carp qw(longmess shortmess);
5 use Scalar::Util qw(refaddr weaken isweak); 5 use Scalar::Util qw(refaddr weaken isweak);
6 6
7 my %instances; 7 my %listeners;
8 my $trapped;
8 9
9 BEGIN { 10 BEGIN {
10 *CORE::GLOBAL::bless = sub { 11 $trapped = 0;
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 } 12 }
26 13
27 sub DumpAlive { 14 sub import {
28 my ($hout) = @_; 15 if (not $trapped) {
29 $hout = *STDOUT unless $hout; 16 *CORE::GLOBAL::bless = sub {
30 print $hout "Alive objects table\n"; 17 $_[1] |= caller unless $_[1];
31 print $hout "-------------------\n"; 18 my $ref = CORE::bless $_[0],$_[1];
32 while (my ($id,$info) = each %instances) { 19
33 delete $instances{$id} and next unless $info->{WeakRef}; 20 $_->track($ref) foreach values %listeners;
34 print "$info->{Class} $id: $info->{WeakRef}\n"; 21
35 } 22 return $ref;
23 };
24 $trapped = 1;
25 }
36 } 26 }
37 27
38 sub StatClasses { 28 sub _ConnectListener {
39 my ($hout) = @_; 29 my ($self,$listener) = @_;
40 $hout = *STDOUT unless $hout; 30
41 print $hout "Statistics by class\n"; 31 die "Invalid listener" unless ref $listener;
42 print $hout "-------------------\n"; 32
43 my %stat; 33 $listeners{refaddr($listener)} = $listener;
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 } 34 }
52 35
53 sub Clear { 36 sub _RemoveListener {
54 undef %instances; 37 my ($self,$listener) = @_;
38
39 die "Invalid listener" unless ref $listener;
40
41 delete $listeners{refaddr($listener)};
55 } 42 }
56 43
44 sub Monitor {
45 my ($self,$code) = @_;
46
47 my $data = IMPL::Profiler::Memory::Data->new();
48
49 $data->Monitor($code);
50
51 return $data;
52 }
53
54 package IMPL::Profiler::Memory::Data;
55 use parent qw(IMPL::Object::Fields);
56
57 use Data::Dumper();
58 use Scalar::Util qw(refaddr weaken isweak);
59
60 use fields qw( objects );
61
62 sub CTOR {
63 my $this = shift;
64 $this->{objects} = [];
65 }
66
67 sub track {
68 my $i = scalar @{$_[0]->{objects}};
69 $_[0]->{objects}[$i] = $_[1];
70 weaken($_[0]->{objects}[$i]);
71 }
72
73 sub Purge {
74 my $this = shift;
75
76 return $this->{objects} = [ grep defined($_), @{$this->{objects}}];
77 }
78
79 sub Dump {
80 my $this = shift;
81 return Data::Dumper->Dump($this->{objects});
82 }
83
84 sub isLeak {
85 my ($this) = @_;
86 $this->Purge();
87 return ( scalar(@{$this->{objects}}) > 0);
88 }
89
90 sub Monitor {
91 my ($this,$code) = @_;
92
93 die "A reference to a subroutine is required" unless ref $code;
94
95 IMPL::Profiler::Memory->_ConnectListener($this);
96 eval {
97 $code->();
98 };
99 my $err = $@;
100 IMPL::Profiler::Memory->_RemoveListener($this);
101
102 die $err if $err;
103
104 return;
105 }
106
107
108
57 1; 109 1;