| Subject: | [PATCH] blessedby and class filter |
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~