Mercurial > pub > Impl
annotate Lib/IMPL/Profiler/Memory.pm @ 215:77a9934a44af
sync, migrating to XML::Compile
| author | cin |
|---|---|
| date | Sun, 19 Aug 2012 22:27:43 +0400 |
| parents | 4d0e1962161c |
| children |
| rev | line source |
|---|---|
| 49 | 1 package IMPL::Profiler::Memory; |
| 2 | |
| 3 use strict; | |
| 4 use Carp qw(longmess shortmess); | |
| 5 use Scalar::Util qw(refaddr weaken isweak); | |
| 6 | |
| 188 | 7 my %listeners; |
| 8 my $trapped; | |
| 49 | 9 |
| 10 BEGIN { | |
| 194 | 11 $trapped = 0; |
| 188 | 12 } |
| 49 | 13 |
| 188 | 14 sub import { |
| 194 | 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 } | |
| 188 | 26 } |
| 49 | 27 |
| 188 | 28 sub _ConnectListener { |
| 194 | 29 my ($self,$listener) = @_; |
| 30 | |
| 31 die "Invalid listener" unless ref $listener; | |
| 32 | |
| 33 $listeners{refaddr($listener)} = $listener; | |
| 188 | 34 } |
| 49 | 35 |
| 188 | 36 sub _RemoveListener { |
| 194 | 37 my ($self,$listener) = @_; |
| 38 | |
| 39 die "Invalid listener" unless ref $listener; | |
| 40 | |
| 41 delete $listeners{refaddr($listener)}; | |
| 188 | 42 } |
| 49 | 43 |
| 188 | 44 sub Monitor { |
| 194 | 45 my ($self,$code) = @_; |
| 46 | |
| 47 my $data = IMPL::Profiler::Memory::Data->new(); | |
| 48 | |
| 49 $data->Monitor($code); | |
| 50 | |
| 51 return $data; | |
| 49 | 52 } |
| 53 | |
| 188 | 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 | |
|
190
cd1ff7029a63
IMLP::Web::View refactored, added new method 'require' which is available inside templates. Changed document rendering.
cin
parents:
189
diff
changeset
|
60 use fields qw( objects counter); |
| 188 | 61 |
| 62 sub CTOR { | |
| 194 | 63 my $this = shift; |
| 64 $this->{objects} = []; | |
| 65 $this->{counter} = 0; | |
| 188 | 66 } |
| 67 | |
| 68 sub track { | |
| 194 | 69 my $i = scalar @{$_[0]->{objects}}; |
| 70 $_[0]->{objects}[$i] = $_[1]; | |
| 71 weaken($_[0]->{objects}[$i]); | |
| 72 $_[0]->{counter} ++; | |
| 188 | 73 } |
| 74 | |
| 75 sub Purge { | |
| 194 | 76 my $this = shift; |
| 77 | |
| 78 return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; | |
| 49 | 79 } |
| 80 | |
| 188 | 81 sub Dump { |
| 194 | 82 my $this = shift; |
| 83 return Data::Dumper->Dump([$this->{objects}]); | |
| 188 | 84 } |
| 49 | 85 |
| 188 | 86 sub isLeak { |
| 194 | 87 my ($this) = @_; |
| 88 $this->Purge(); | |
| 89 return ( scalar(@{$this->{objects}}) > 0); | |
| 49 | 90 } |
| 91 | |
| 188 | 92 sub Monitor { |
| 194 | 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; | |
| 49 | 107 } |
| 108 | |
| 188 | 109 |
| 110 | |
| 49 | 111 1; |