annotate lib/IMPL/Profiler/Memory.pm @ 427:09e0086a82a7 ref20150831 tip

Merge
author cin
date Tue, 15 May 2018 00:51:33 +0300
parents c6e90e02dd17
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
1 package IMPL::Profiler::Memory;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
2
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
3 use strict;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
4 use Carp qw(longmess shortmess);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
5 use Scalar::Util qw(refaddr weaken isweak);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
6
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
7 my %listeners;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
8 my $trapped;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
9
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
10 BEGIN {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
11 $trapped = 0;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
12 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
13
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
14 sub import {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
15 if (not $trapped) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
16 *CORE::GLOBAL::bless = sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
17 $_[1] |= caller unless $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
18 my $ref = CORE::bless $_[0],$_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
19
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
20 $_->track($ref) foreach values %listeners;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
21
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
22 return $ref;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
23 };
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
24 $trapped = 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
25 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
26 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
27
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
28 sub _ConnectListener {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
29 my ($self,$listener) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
30
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
31 die "Invalid listener" unless ref $listener;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
32
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
33 $listeners{refaddr($listener)} = $listener;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
34 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
35
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
36 sub _RemoveListener {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
37 my ($self,$listener) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
38
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
39 die "Invalid listener" unless ref $listener;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
40
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
41 delete $listeners{refaddr($listener)};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
42 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
43
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
44 sub Monitor {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
45 my ($self,$code) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
46
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
47 my $data = IMPL::Profiler::Memory::Data->new();
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
48
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
49 $data->Monitor($code);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
50
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
51 return $data;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
52 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
53
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
54 package IMPL::Profiler::Memory::Data;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
55 use parent qw(IMPL::Object::Fields);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
56
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
57 use Data::Dumper();
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
58 use Scalar::Util qw(refaddr weaken isweak);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
59
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
60 use fields qw( objects counter);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
61
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
62 sub CTOR {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
63 my $this = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
64 $this->{objects} = [];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
65 $this->{counter} = 0;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
66 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
67
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
68 sub track {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
69 my $i = scalar @{$_[0]->{objects}};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
70 $_[0]->{objects}[$i] = $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
71 weaken($_[0]->{objects}[$i]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
72 $_[0]->{counter} ++;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
73 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
74
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
75 sub Purge {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
76 my $this = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
77
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
78 return $this->{objects} = [ grep defined($_), @{$this->{objects}}];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
79 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
80
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
81 sub Dump {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
82 my $this = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
83 return Data::Dumper->Dump([$this->{objects}]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
84 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
85
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
86 sub isLeak {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
87 my ($this) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
88 $this->Purge();
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
89 return ( scalar(@{$this->{objects}}) > 0);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
90 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
91
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
92 sub Monitor {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
93 my ($this,$code) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
94
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
95 die "A reference to a subroutine is required" unless ref $code;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
96
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
97 IMPL::Profiler::Memory->_ConnectListener($this);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
98 eval {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
99 $code->();
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
100 };
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
101 my $err = $@;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
102 IMPL::Profiler::Memory->_RemoveListener($this);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
103
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
104 die $err if $err;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
105
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
106 return;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
107 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
108
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
109
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
110
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
111 1;