Skip Menu |
 

This queue is for tickets about the Devel-Leak-Object CPAN distribution.

Report information
The Basics
Id: 21145
Status: open
Priority: 0/
Queue: Devel-Leak-Object

People
Owner: Nobody in particular
Requestors: CLKAO [...] cpan.org
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: (no value)



Subject: [PATCH] blessedby and class filter
Download (untitled) / with headers
text/plain 206b
Attached is a unpolished patch, doing pretty much what I want. I think import should probably pollute CORE::GLOBAL::bless anyway. I made other arguments to import as regex matching the interested classes.
Subject: devel-leak-object.patch
diff -ru /home/clkao/.cpan/build/Devel-Leak-Object-0.02/lib/Devel/Leak/Object.pm lib/Devel/Leak/Object.pm --- /home/clkao/.cpan/build/Devel-Leak-Object-0.02/lib/Devel/Leak/Object.pm Mon Sep 20 06:53:39 2004 +++ lib/Devel/Leak/Object.pm Wed Aug 23 02:31:07 2006 @@ -1,6 +1,7 @@ package Devel::Leak::Object; use strict; +use warnings; BEGIN { use Exporter (); @@ -68,14 +69,14 @@ =cut use Carp; +use Scalar::Util 'refaddr'; -our %objcount; -our %tracked; -our %destroy_orig; +our (%objcount, %tracked, %destroy_orig, %blessedby); -use Data::Dumper; +my $CLASSES; sub import { + my $class = shift; for my $i (0..$#_) { next unless $_[$i] =~ /^GLOBAL_(.*)/; my $sym = $1; @@ -83,13 +84,16 @@ no strict 'refs'; *{'CORE::GLOBAL::'.$sym} = \&{$sym}; } - goto &Exporter::import; + $CLASSES = join('|', @_); + $CLASSES = qr($CLASSES)o; + return; } sub bless { my ($ref,$pkg) = @_; + $pkg ||= (caller)[0]; my $obj = CORE::bless($ref,$pkg); - Devel::Leak::Object::track($obj); + Devel::Leak::Object::track($obj) if !$CLASSES || $pkg =~ $CLASSES; $obj; }; @@ -97,15 +101,12 @@ { my $obj = shift; - my ($class,$type,$addr) = "$obj" =~ /^ - ((?:\w|\:\:)+) # Stringification has pkg name - =(ARRAY|HASH|SCALAR|GLOB|CODE) # type - \((0x[0-9a-f]+)\) # and address - /x or carp "Not passed an object"; + my ($class,$type,$addr) = (ref($obj), undef, refaddr($obj)); if (exists $tracked{$addr}) { # rebless of tracked object $objcount{$tracked{$addr}}--; } $tracked{$addr} = $class; + $blessedby{$addr} = Carp::longmess; if (!exists $objcount{$class}) { no strict 'refs'; if ((exists ${$class.'::'}{DESTROY}) && @@ -113,31 +114,34 @@ $destroy_orig{$class} = \&{$class.'::DESTROY'}; } *{$class.'::DESTROY'} = \&_DESTROY_stub; + no warnings 'once'; ${$class.'::DESTROY_stubbed'} = 1; } $objcount{$class}++; } -sub status { - print "Status of all classes:\n"; - for (sort keys %objcount) { - printf "%-40s %d\n", $_, $objcount{$_}; - } +END { + use Data::Dumper; + warn Dumper(\%blessedby); + warn "Status of all classes:\n"; + for (sort keys %objcount) { + warn sprintf "%-40s %d\n", $_, $objcount{$_}; + } } sub _DESTROY_stub { my ($obj) = @_; - my ($class,$type,$addr) = "$obj" =~ /^ - ((?:\w|\:\:)+) # Stringification has pkg name - =(ARRAY|HASH|SCALAR|GLOB|CODE) # type - \((0x[0-9a-f]+)\) # and address - /x or carp "Not passed an object"; + my ($class,$type,$addr) = (ref($obj), undef, refaddr($obj)); + if (exists($objcount{$class})) { $objcount{$class}--; warn "Object count for $class negative ($objcount{$class})\n" if $objcount{$class} < 0; warn "Object not tracked" unless exists $tracked{$addr}; +# use Devel::Size 'total_size'; +# warn "==> bye $class $addr ".total_size($obj); delete $tracked{$addr}; + delete $blessedby{$addr}; } goto &{$destroy_orig{$class}} if exists $destroy_orig{$class}; @@ -158,9 +162,6 @@ } } -END { - status(); -} 1; #this line is important and will help the module return a true value __END__ Only in lib/Devel/Leak: Object.pm~
Download (untitled) / with headers
text/plain 486b
On Wed Aug 23 01:35:51 2006, CLKAO wrote: Show quoted text
> Attached is a unpolished patch, doing pretty much what I want. > > I think import should probably pollute CORE::GLOBAL::bless anyway. I > made other arguments to import as regex matching the interested classes.
The patch is now applied, and all tests pass. This is available in my svn repository: http://www.ivorw.com/svn/cpan/Devel-Leak-Object/trunk/ I have some other changes to apply, and will consider a release after adding these.
From: RUZ [...] cpan.org
Download (untitled) / with headers
text/plain 850b
Hi. Clkao's patch is really useful as well as the module, but it introduce one small bug. When we track ^Foo:: namespace and object from this space is reblessed into Bar::XXX the module looses track and counters are wrong. Attching the patch with a fix and tests. On Fri Aug 25 13:35:20 2006, IVORW wrote: Show quoted text
> On Wed Aug 23 01:35:51 2006, CLKAO wrote:
> > Attached is a unpolished patch, doing pretty much what I want. > > > > I think import should probably pollute CORE::GLOBAL::bless anyway. I > > made other arguments to import as regex matching the interested classes.
> > The patch is now applied, and all tests pass. > > This is available in my svn repository: > > http://www.ivorw.com/svn/cpan/Devel-Leak-Object/trunk/ > > I have some other changes to apply, and will consider a release after > adding these.
-- Best regards, Ruslan.
=== lib/Devel/Leak/Object.pm ================================================================== --- lib/Devel/Leak/Object.pm (revision 13979) +++ lib/Devel/Leak/Object.pm (local) @@ -93,7 +93,7 @@ my ($ref,$pkg) = @_; $pkg ||= (caller)[0]; my $obj = CORE::bless($ref,$pkg); - Devel::Leak::Object::track($obj) if !$CLASSES || $pkg =~ $CLASSES; + Devel::Leak::Object::track($obj) if !$CLASSES || $tracked{refaddr($obj)} || $pkg =~ $CLASSES; $obj; }; === t/003_rebless_regexp.t ================================================================== --- t/003_rebless_regexp.t (revision 13979) +++ t/003_rebless_regexp.t (local) @@ -0,0 +1,37 @@ +# -*- perl -*- + +# t/003_rebless.t - check object reblessing + +use Test::More tests => 8; + +#01 +BEGIN { + use_ok( 'Devel::Leak::Object', qw(GLOBAL_bless ^Foo::Bar$) ); +} + +my $foo = bless {}, 'Foo::Bar'; + +#02 +isa_ok($foo, 'Foo::Bar', "Before the tests"); + +#03 +is ($Devel::Leak::Object::objcount{Foo::Bar},1,'One Foo::Bar object'); + +$foo = bless $foo, 'Foo::Baz'; + +#04 +is ($Devel::Leak::Object::objcount{Foo::Bar},0,'No Foo::Bar objects'); + +#05 +is ($Devel::Leak::Object::objcount{Foo::Baz},1,'One Foo::Baz object'); + +undef $foo; + +#06 +is ($Devel::Leak::Object::objcount{Foo::Bar},0,'no objects left'); + +#07 +is ($Devel::Leak::Object::objcount{Foo::Baz},0,'no objects left'); + +#08 +is (scalar(keys %Devel::Leak::Object::tracked), 0, 'Nothing still tracked');


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.