Mercurial > pub > Impl

comparison lib/IMPL/Profiler/Memory.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
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 %listeners;
8 my $trapped;
9
10 BEGIN {
11 $trapped = 0;
12 }
13
14 sub import {
15 if (not $trapped) {
16 *CORE::GLOBAL::bless = sub {
17 $_[1] |= caller unless $_[1];
18 my $ref = CORE::bless $_[0],$_[1];
19
20 $_->track($ref) foreach values %listeners;
21
22 return $ref;
23 };
24 $trapped = 1;
25 }
26 }
27
28 sub _ConnectListener {
29 my ($self,$listener) = @_;
30
31 die "Invalid listener" unless ref $listener;
32
33 $listeners{refaddr($listener)} = $listener;
34 }
35
36 sub _RemoveListener {
37 my ($self,$listener) = @_;
38
39 die "Invalid listener" unless ref $listener;
40
41 delete $listeners{refaddr($listener)};
42 }
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 counter);
61
62 sub CTOR {
63 my $this = shift;
64 $this->{objects} = [];
65 $this->{counter} = 0;
66 }
67
68 sub track {
69 my $i = scalar @{$_[0]->{objects}};
70 $_[0]->{objects}[$i] = $_[1];
71 weaken($_[0]->{objects}[$i]);
72 $_[0]->{counter} ++;
73 }
74
75 sub Purge {
76 my $this = shift;
77
78 return $this->{objects} = [ grep defined($_), @{$this->{objects}}];
79 }
80
81 sub Dump {
82 my $this = shift;
83 return Data::Dumper->Dump([$this->{objects}]);
84 }
85
86 sub isLeak {
87 my ($this) = @_;
88 $this->Purge();
89 return ( scalar(@{$this->{objects}}) > 0);
90 }
91
92 sub Monitor {
93 my ($this,$code) = @_;
94
95 die "A reference to a subroutine is required" unless ref $code;
96
97 IMPL::Profiler::Memory->_ConnectListener($this);
98 eval {
99 $code->();
100 };
101 my $err = $@;
102 IMPL::Profiler::Memory->_RemoveListener($this);
103
104 die $err if $err;
105
106 return;
107 }
108
109
110
111 1;