Mercurial > pub > Impl

comparison Lib/IMPL/Profiler/Memory.pm @ 194:4d0e1962161c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Replaced tabs with spaces IMPL::Web::View - fixed document model, new features (control classes, document constructor parameters)
author cin
date Tue, 10 Apr 2012 20:08:29 +0400
parents cd1ff7029a63
children
comparison
equal deleted inserted replaced
193:8e8401c0aea4 194:4d0e1962161c
6 6
7 my %listeners; 7 my %listeners;
8 my $trapped; 8 my $trapped;
9 9
10 BEGIN { 10 BEGIN {
11 $trapped = 0; 11 $trapped = 0;
12 } 12 }
13 13
14 sub import { 14 sub import {
15 if (not $trapped) { 15 if (not $trapped) {
16 *CORE::GLOBAL::bless = sub { 16 *CORE::GLOBAL::bless = sub {
17 $_[1] |= caller unless $_[1]; 17 $_[1] |= caller unless $_[1];
18 my $ref = CORE::bless $_[0],$_[1]; 18 my $ref = CORE::bless $_[0],$_[1];
19 19
20 $_->track($ref) foreach values %listeners; 20 $_->track($ref) foreach values %listeners;
21 21
22 return $ref; 22 return $ref;
23 }; 23 };
24 $trapped = 1; 24 $trapped = 1;
25 } 25 }
26 } 26 }
27 27
28 sub _ConnectListener { 28 sub _ConnectListener {
29 my ($self,$listener) = @_; 29 my ($self,$listener) = @_;
30 30
31 die "Invalid listener" unless ref $listener; 31 die "Invalid listener" unless ref $listener;
32 32
33 $listeners{refaddr($listener)} = $listener; 33 $listeners{refaddr($listener)} = $listener;
34 } 34 }
35 35
36 sub _RemoveListener { 36 sub _RemoveListener {
37 my ($self,$listener) = @_; 37 my ($self,$listener) = @_;
38 38
39 die "Invalid listener" unless ref $listener; 39 die "Invalid listener" unless ref $listener;
40 40
41 delete $listeners{refaddr($listener)}; 41 delete $listeners{refaddr($listener)};
42 } 42 }
43 43
44 sub Monitor { 44 sub Monitor {
45 my ($self,$code) = @_; 45 my ($self,$code) = @_;
46 46
47 my $data = IMPL::Profiler::Memory::Data->new(); 47 my $data = IMPL::Profiler::Memory::Data->new();
48 48
49 $data->Monitor($code); 49 $data->Monitor($code);
50 50
51 return $data; 51 return $data;
52 } 52 }
53 53
54 package IMPL::Profiler::Memory::Data; 54 package IMPL::Profiler::Memory::Data;
55 use parent qw(IMPL::Object::Fields); 55 use parent qw(IMPL::Object::Fields);
56 56
58 use Scalar::Util qw(refaddr weaken isweak); 58 use Scalar::Util qw(refaddr weaken isweak);
59 59
60 use fields qw( objects counter); 60 use fields qw( objects counter);
61 61
62 sub CTOR { 62 sub CTOR {
63 my $this = shift; 63 my $this = shift;
64 $this->{objects} = []; 64 $this->{objects} = [];
65 $this->{counter} = 0; 65 $this->{counter} = 0;
66 } 66 }
67 67
68 sub track { 68 sub track {
69 my $i = scalar @{$_[0]->{objects}}; 69 my $i = scalar @{$_[0]->{objects}};
70 $_[0]->{objects}[$i] = $_[1]; 70 $_[0]->{objects}[$i] = $_[1];
71 weaken($_[0]->{objects}[$i]); 71 weaken($_[0]->{objects}[$i]);
72 $_[0]->{counter} ++; 72 $_[0]->{counter} ++;
73 } 73 }
74 74
75 sub Purge { 75 sub Purge {
76 my $this = shift; 76 my $this = shift;
77 77
78 return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; 78 return $this->{objects} = [ grep defined($_), @{$this->{objects}}];
79 } 79 }
80 80
81 sub Dump { 81 sub Dump {
82 my $this = shift; 82 my $this = shift;
83 return Data::Dumper->Dump([$this->{objects}]); 83 return Data::Dumper->Dump([$this->{objects}]);
84 } 84 }
85 85
86 sub isLeak { 86 sub isLeak {
87 my ($this) = @_; 87 my ($this) = @_;
88 $this->Purge(); 88 $this->Purge();
89 return ( scalar(@{$this->{objects}}) > 0); 89 return ( scalar(@{$this->{objects}}) > 0);
90 } 90 }
91 91
92 sub Monitor { 92 sub Monitor {
93 my ($this,$code) = @_; 93 my ($this,$code) = @_;
94 94
95 die "A reference to a subroutine is required" unless ref $code; 95 die "A reference to a subroutine is required" unless ref $code;
96 96
97 IMPL::Profiler::Memory->_ConnectListener($this); 97 IMPL::Profiler::Memory->_ConnectListener($this);
98 eval { 98 eval {
99 $code->(); 99 $code->();
100 }; 100 };
101 my $err = $@; 101 my $err = $@;
102 IMPL::Profiler::Memory->_RemoveListener($this); 102 IMPL::Profiler::Memory->_RemoveListener($this);
103 103
104 die $err if $err; 104 die $err if $err;
105 105
106 return; 106 return;
107 } 107 }
108 108
109 109
110 110
111 1; 111 1;