Bug #12942 for Devel-Leak-Object: Fix for objects which override stringify

[guest - Tue May 24 10:12:25 2005]: Show quoted text
That patch was broken - reftype and refaddr were transposed so tracking was b0rk. Attached patch replaces the first one, adds a few extra features. See also http://www.perlmonks.org/?node_id=150796 for a "what's the REFCNT of this object?" thread. I'll probably do a little more work on this, but I also suspect that once I get answers to my questions I'll have to abandon the patching at whatever point I reach. Hope that's useful,

--- Object.pm~~ 2005-05-25 10:58:01.000000000 +0100 +++ Object.pm 2005-05-25 17:31:47.000000000 +0100 @@ -69,11 +69,14 @@ use Carp; -our %objcount; -our %tracked; -our %destroy_orig; +our %objcount; # key = class, value = running total of outstanding objects +our %tracked; # key = address, value = class +our %obj_seen; # key = address, value = weakened ref to object +our %destroy_orig; # key = package, value = original DESTROY CODE use Data::Dumper; +use Scalar::Util qw(weaken blessed reftype refaddr); +use B 'svref_2object'; sub import { for my $i (0..$#_) { @@ -88,6 +91,7 @@ sub bless { my ($ref,$pkg) = @_; + $pkg = (caller)[0] unless defined $pkg; # a call of "bless {}", e.g. in DBI my $obj = CORE::bless($ref,$pkg); Devel::Leak::Object::track($obj); $obj; @@ -97,23 +101,24 @@ { 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) = _getinfo($obj); if (exists $tracked{$addr}) { # rebless of tracked object $objcount{$tracked{$addr}}--; } $tracked{$addr} = $class; + + $obj_seen{$addr} = $obj; + weaken($obj_seen{$addr}); + if (!exists $objcount{$class}) { no strict 'refs'; if ((exists ${$class.'::'}{DESTROY}) && *{$class.'::DESTROY'}{CODE}) { $destroy_orig{$class} = \&{$class.'::DESTROY'}; } - *{$class.'::DESTROY'} = \&_DESTROY_stub; ${$class.'::DESTROY_stubbed'} = 1; + no warnings; + *{$class.'::DESTROY'} = \&_DESTROY_stub; } $objcount{$class}++; } @@ -125,13 +130,43 @@ } } +sub get_status () { + return %objcount; +} + +sub get_seen () { + my %collect; # key = class, value = list of outstanding objects + foreach my $addr (keys %obj_seen) { + my $obj = $obj_seen{$addr}; + if (!defined $obj) { + # Weak ref has become undef. Just tidy up and move on. + delete $obj_seen{$addr}; + next; + } + my ($class,$type,$addr) = _getinfo($obj); + my $list = $collect{$class} ||= []; + push @$list, $obj; + } + return %collect; +} + +sub get_refinfo ($) { + my $bsv = svref_2object(shift); + return (ref($bsv), $bsv->REFCNT); +} + +sub _getinfo { + my $obj = shift; + my @info = (blessed($obj), + reftype($obj), + sprintf("0x%X", refaddr($obj))); + carp "Not passed an object" unless defined $info[0]; + return @info; +} + 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) = _getinfo($obj); if (exists($objcount{$class})) { $objcount{$class}--; warn "Object count for $class negative ($objcount{$class})\n"