Mercurial > pub > Impl
view lib/IMPL/Profiler/Memory.pm @ 412:30e8c6a74937 ref20150831
working on di container (role based registrations)
author | cin |
---|---|
date | Mon, 21 Sep 2015 19:54:10 +0300 |
parents | c6e90e02dd17 |
children |
line wrap: on
line source
package IMPL::Profiler::Memory; use strict; use Carp qw(longmess shortmess); use Scalar::Util qw(refaddr weaken isweak); my %listeners; my $trapped; BEGIN { $trapped = 0; } sub import { if (not $trapped) { *CORE::GLOBAL::bless = sub { $_[1] |= caller unless $_[1]; my $ref = CORE::bless $_[0],$_[1]; $_->track($ref) foreach values %listeners; return $ref; }; $trapped = 1; } } sub _ConnectListener { my ($self,$listener) = @_; die "Invalid listener" unless ref $listener; $listeners{refaddr($listener)} = $listener; } sub _RemoveListener { my ($self,$listener) = @_; die "Invalid listener" unless ref $listener; delete $listeners{refaddr($listener)}; } sub Monitor { my ($self,$code) = @_; my $data = IMPL::Profiler::Memory::Data->new(); $data->Monitor($code); return $data; } package IMPL::Profiler::Memory::Data; use parent qw(IMPL::Object::Fields); use Data::Dumper(); use Scalar::Util qw(refaddr weaken isweak); use fields qw( objects counter); sub CTOR { my $this = shift; $this->{objects} = []; $this->{counter} = 0; } sub track { my $i = scalar @{$_[0]->{objects}}; $_[0]->{objects}[$i] = $_[1]; weaken($_[0]->{objects}[$i]); $_[0]->{counter} ++; } sub Purge { my $this = shift; return $this->{objects} = [ grep defined($_), @{$this->{objects}}]; } sub Dump { my $this = shift; return Data::Dumper->Dump([$this->{objects}]); } sub isLeak { my ($this) = @_; $this->Purge(); return ( scalar(@{$this->{objects}}) > 0); } sub Monitor { my ($this,$code) = @_; die "A reference to a subroutine is required" unless ref $code; IMPL::Profiler::Memory->_ConnectListener($this); eval { $code->(); }; my $err = $@; IMPL::Profiler::Memory->_RemoveListener($this); die $err if $err; return; } 1;