Devel-Monitor
view release on metacpan or search on metacpan
lib/Devel/Monitor.pm view on Meta::CPAN
#Little redirect to be "Perl compliant"
#TODO : use the underscore syntax
sub print_circular_ref { return printCircularRef(@_); }
sub printCircularRef {
my $varRef = shift;
my $hideWeakenedCircRef = shift; #Boolean
my $source = shift;
my $trace = shift; #A array container containing the current trace
my $weakenedRef = shift; #A array containing the trace to the weakened ref it any
my $origRef = shift; #Contains original reference to verify circular references
my $seenRef = shift;
my $circRefTypesRef = shift;
#print STDERR "###############################################################\n";
#print STDERR "VARIABLE : ".$varRef."\n";
#print STDERR "TYPE : ".ref($varRef)."\n";
my $isFirst = (!$origRef);
$trace = Devel::Monitor::Trace->new() if not $trace;
$weakenedRef = [] if not $weakenedRef;
$seenRef = {} if not $seenRef;
$circRefTypesRef = [] if not $circRefTypesRef;
return undef if not $varRef;
my $isWeak = 0;
my $simpleSeenRef = {};
#Since we dereference scalars, they are not displayed on the final prints
while ($varRef =~ /REF/) {
#print STDERR "DEREFERING $varRef ($$varRef)\n";
#print STDERR "Current variable : $varRef from ".\$varRef."\n";
if (isweak($$varRef)) {
$isWeak = 1;
#print STDERR "WEAK for $$varRef\n";
push(@$weakenedRef, $$varRef);
}
_addSeenRef($varRef,$simpleSeenRef);
#Exceptional case : $a = \$a or $a = \$b = \$c
#TODO : This "if" should not be handled as an exception (At least, we should try)
if (exists($simpleSeenRef->{$varRef}) && ($simpleSeenRef->{$varRef} > 1)) {
if ($isFirst) {
_printCircularRefHeader($varRef);
push(@$circRefTypesRef, CRT_CIRC_REF());
Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
Devel::Monitor::Common::printMsg("Circular reference on scalar(s) starting at $varRef\n");
lib/Devel/Monitor.pm view on Meta::CPAN
}
return undef;
}
$varRef = $$varRef;
}
$trace->push($varRef,$source);
_addSeenRef($varRef,$seenRef) if $origRef; #We skip the first item which is $origRef
#print STDERR "--------------------------------------------\n";
#print STDERR "Current variable : $varRef from ".\$varRef."\n";
my $circRefType = _checkCircularRef($varRef,$hideWeakenedCircRef,$trace,$weakenedRef,$origRef,$seenRef);
#print STDERR "\$circRefType : $circRefType\n";
if ($circRefType) {
$trace->pop();
push(@$circRefTypesRef, $circRefType);
return undef; #Don't go any further because we loop
}
if ($isFirst) {
$origRef = $varRef;
_printCircularRefHeader($origRef);
}
#print STDERR 'Current trace : '.$trace->getCircularPath()."\n";
_printCircularRef($varRef,$hideWeakenedCircRef,$source,$trace,$weakenedRef,$origRef,$seenRef,$circRefTypesRef);
#We go into another branch
$trace->pop();
pop(@$weakenedRef) if $isWeak; # Remove weakened item
delete($seenRef->{$varRef}); # Remove varRef from "seen" hash
_printCircularRefResults($origRef,$circRefTypesRef) if $isFirst;
return undef;
}
sub _printCircularRef {
my $varRef = shift;
my $hideWeakenedCircRef = shift;
my $source = shift;
my $trace = shift;
my $weakenedRef = shift;
my $origRef = shift;
my $seenRef = shift;
my $circRefTypesRef = shift;
if ($varRef =~ /HASH/ ) { #An object or an hash
HASH_ITEM:
Devel::Monitor::Common::printMsg('Object '.$trace->getCircularPath().' = '.$varRef." is tied. Untie it to check circular references for this object.\n") if tied(%$varRef);
foreach my $item (keys %$varRef) {
my $ref = _getVarRef(\($varRef->{$item}));
printCircularRef($ref,$hideWeakenedCircRef,'{'.$item.'}',$trace,$weakenedRef,$origRef,$seenRef,$circRefTypesRef);
}
}
elsif ($varRef =~ /SCALAR|CODE/) {
#No circular references are possible here, so we don't do anything
}
elsif ($varRef =~ /ARRAY/) {
ARRAY_ITEM:
Devel::Monitor::Common::printMsg('Object '.$trace->getCircularPath().' = '.$varRef." is tied. Untie it to check circular references for this object.\n") if tied(@$varRef);
for (my $i=0; $i<scalar(@$varRef); $i++) {
#print STDERR "CURRENT VAR : ".\($varRef->[$i])." ::: ".$varRef->[$i]."\n";
my $ref = _getVarRef(\($varRef->[$i]));
#Devel::Monitor::Common::printMsg('Object at '.$trace->getCircularPath().'['.$i.']'.
#" is ARRAY ARRAY ARRAY tied. We cannot check circular references for this object.\n") if $ref =~ /SCALAR/;
printCircularRef($ref,$hideWeakenedCircRef,'['.$i.']',$trace,$weakenedRef,$origRef,$seenRef,$circRefTypesRef);
}
} else {
#Other objects
my $runPatch = 0;
try {
goto HASH_ITEM;
} otherwise {
$runPatch = 1;
};
if ($runPatch) {
lib/Devel/Monitor.pm view on Meta::CPAN
# METH _checkCircularRef
#
# DESC Verify if there is a circular reference on the current variable
# RETV Circular Reference Type
# One of : CRT_NONE, CRT_CIRC_REF, CRT_WEAK_CIRC_REF, CRT_INTERNAL_CIRC_REF
sub _checkCircularRef {
my $varRef = shift;
my $hideWeakenedCircRef = shift;
my $trace = shift;
my $weakenedRef = shift;
my $origRef = shift;
my $seenRef = shift;
if ($varRef) {
#print STDERR "\$varRef : $varRef\n";
#print STDERR "\$origRef : $origRef\n";
if ($origRef) {
#If we found the original reference
my $isCircRef = ($varRef eq $origRef);
#If we found a reference more than one time, it means we loop infinitely
my $isInternalCircRef = (exists($seenRef->{$varRef}) && ($seenRef->{$varRef} > 1));
if ($isCircRef || $isInternalCircRef) {
my $weakenedInCircRefRef = _getWeakenedInCircRef($trace,$weakenedRef);
my $isWeakenedItems = (scalar(@$weakenedInCircRefRef) > 0);
if (!$hideWeakenedCircRef || #If we show everything
($hideWeakenedCircRef && !$isWeakenedItems)) { #Otherwise, if there is no weak reference
Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
if ($isCircRef) {
Devel::Monitor::Common::printMsg('Circular reference found : '.$trace->getCircularPath()."\n");
}
elsif ($isInternalCircRef) {
Devel::Monitor::Common::printMsg('Internal circular reference found : '.$trace->getCircularPath()." on $varRef\n");
}
if ($isWeakenedItems) {
Devel::Monitor::Common::printMsg('with weakened reference on : '.join(', ', @$weakenedInCircRefRef)."\n");
}
$trace->dump();
Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
return CRT_WEAK_CIRC_REF() if $isWeakenedItems;
return CRT_CIRC_REF() if $isCircRef;
return CRT_INTERNAL_CIRC_REF() if $isInternalCircRef;
die("_checkCircularRef : Should not be here (1)\n");
}
elsif ($hideWeakenedCircRef && $isWeakenedItems) {
return CRT_WEAK_CIRC_REF();
lib/Devel/Monitor.pm view on Meta::CPAN
# ($$varRef =~ /(ARRAY|HASH)/)) {
# $ref = $$varRef;
#} else {
$ref = $varRef;
#}
return $ref;
}
sub _getWeakenedInCircRef {
my $trace = shift;
my $weakenedRef = shift;
my @weakenedInCircRef;
my $traceItemsRef = $trace->getTraceItems;
#The last item represent the circular reference
my $traceItemCircRef = $traceItemsRef->[$#$traceItemsRef];
#for my $i (($#$traceItemsRef-1)..0) {
for (my $i=($#$traceItemsRef-1); $i>=0; $i--) {
#Get the current item
my $traceItem = $traceItemsRef->[$i];
#print STDERR "traceItem ".$traceItem->getVarRef()."\n";
#We verify that the item is a weaken reference or not
foreach my $weakened (@$weakenedRef) {
#print STDERR "weakened ".$weakened."\n";
if ($traceItem->getVarRef() eq $weakened) {
#print STDERR "push\n";
push(@weakenedInCircRef, $weakened);
}
}
#We finish when we end the circular reference
last if ($traceItem->getVarRef() eq $traceItemCircRef->getVarRef());
}
#print STDERR "RETURN ".join(', ', @weakenedInCircRef)."\n";
return \@weakenedInCircRef;
}
1;
__END__
=head1 NAME
Devel::Monitor - Monitor your variables/objects for memory leaks
lib/Devel/Monitor.pm view on Meta::CPAN
}
print "Scope left\n";
#--------------------------------------------------------------------
# ClassA (Just a class with the "printSomething" method)
#--------------------------------------------------------------------
package ClassA;
use strict;
use warnings;
use Scalar::Util qw(weaken isweak);
sub new {
my ($class) = @_;
my $self = {};
bless($self => $class);
return $self;
}
sub getClassB {
my $self = shift;
lib/Devel/Monitor.pm view on Meta::CPAN
print "Something\n";
}
#--------------------------------------------------------------------
# ClassB (A class that got a "parent" which is a ClassA instance)
#--------------------------------------------------------------------
package ClassB;
use strict;
use warnings;
use Scalar::Util qw(weaken isweak);
sub new {
my ($class, $classA) = @_;
my $self = {};
bless($self => $class);
$self->setClassA($classA);
return $self;
}
sub setClassA {
lib/Devel/Monitor.pm view on Meta::CPAN
MONITOR HASH : $b
Something
Leaving scope
Scope left
DESTROY HASH : $b
#------------------------------------------------------------------------------+
#
# We see that the object reference by $b isn't destroyed when leaving the scope
# because $a->{_classB} still use it. So, we got a circular reference here. We must
# weaken one side of the circular reference to help Perl disallocate memory.
#
#------------------------------------------------------------------------------+
#------------------------------------------------------------------------------+
# Wrong way to break circular references
#------------------------------------------------------------------------------+
sub getClassB {
my $self = shift;
$self->{_classB} = ClassB->new($self); #$self->{_classB} is the only
#reference to the objects
weaken($self->{_classB}); #we weaken the only reference,
#so, $self->{_classB} is DESTROYED HERE,
#which is very bad
print "\$self->{_classB} is now weaken\n" if isweak($self->{_classB});
return $self->{_classB};
}
#------------------------------------------------------------------------------+
# Good way
#------------------------------------------------------------------------------+
sub getClassB {
my $self = shift;
my $b = ClassB->new($self);
$self->{_classB} = $b; #we create a second reference to the object
weaken($self->{_classB}); #we weaken this reference, which is not deleted
#because thre is another reference
print "\$self->{_classB} is now weaken\n" if isweak($self->{_classB});
return $self->{_classB};
}
#------------------------------------------------------------------------------+
# Be careful ! With this code, it won't work
#------------------------------------------------------------------------------+
sub getClassB {
my $self = shift;
{
my $b = ClassB->new($self);
$self->{_classB} = $b; #we create a second reference to the object
weaken($self->{_classB}); #we weaken this reference, which is not deleted
#because thre is another reference
print "\$self->{_classB} is now weaken\n" if isweak($self->{_classB});
} #$b is destroyed here, and the other reference $self->{_classB} is a weak reference,
#so the ClassB instance is destroyed, $self->{_classB} now equal undef
return $self->{_classB};
}
#------------------------------------------------------------------------------+
# Good way
#------------------------------------------------------------------------------+
sub getClassB {
my $self = shift;
my $b;
{
$b = ClassB->new($self);
$self->{_classB} = $b; #we create a second reference to the object
weaken($self->{_classB}); #we weaken this reference, which is not deleted
#because thre is another reference
print "\$self->{_classB} is now weaken\n" if isweak($self->{_classB});
} #$b is still not destroyed, so we didn't lose our not weak reference
return $self->{_classB}; #We return the object, someone on the other side will now keep
#the reference, so we don't care if $b lose the reference.
#Our job is done !
}
#------------------------------------------------------------------------------+
#
# Conclusion : You must be sure that you keep a non weak reference to the object
#
#------------------------------------------------------------------------------+
#------------------------------------------------------------------------------+
#
# The output (Using the good way) will be
#
#------------------------------------------------------------------------------+
$self->{_classB} is now weaken
MONITOR HASH : $b
Something
Leaving scope
DESTROY HASH : $b
Scope left
#------------------------------------------------------------------------------+
#
# There is no circular references now...
#
#------------------------------------------------------------------------------+
#------------------------------------------------------------------------------+
#
# IMPORTANT : Always weaken the caller's reference because someone may use the
# child objects (ClassB) this way. Let's see what can happen if you don't.
#
# If we get the following code
#
#------------------------------------------------------------------------------+
my $b;
{
my $a = ClassA->new();
monitor('$a' => \$a);
$b = ClassB->new($a);
lib/Devel/Monitor.pm view on Meta::CPAN
$b->getClassA()->printSomething();
#------------------------------------------------------------------------------+
#
# And the sub setClassA
#
#------------------------------------------------------------------------------+
sub setClassA {
my ($self, $classA) = @_;
$self->{_classA} = $classA;
weaken($self->{_classA});
print "\$self->{_classA} is now weaken\n" if isweak($self->{_classA});
}
#------------------------------------------------------------------------------+
#
# You'll get this error
#
#------------------------------------------------------------------------------+
MONITOR HASH : $a
$self->{_classA} is now weaken
Something
Leaving scope
DESTROY HASH : $a
Scope left
Can't call method "printSomething" on an undefined value at test3.pl line 29.
#------------------------------------------------------------------------------+
#
# $a is destroyed when leaving the scope, and the other reference to this variable
# is weaken, so this one is destroyed too. This clearly demonstrate that you must
# weaken the caller's reference.
#
#------------------------------------------------------------------------------+
=head1 THINGS YOU SHOULD BE AWARE OF
=head2 Loop variables are passed by references
Let's see in details what output you get when monitoring variables inside a loop.
+----------------------+
lib/Devel/Monitor.pm view on Meta::CPAN
KEY:b, KEY REF:SCALAR(0x825564c), VALUE:2, VALUE REF:SCALAR(0x825567c)
Devel::Monitor::TestHash::DESTROY : Devel::Monitor::TestHash=HASH(0x81412e8)
+----------------------+
| Meaning |
+----------------------+
Hash keys refering 1 and 2 can't be the same reference. But we see the
opposite on these small examples. It seems like tied objects reuse memory space
instead of refering to the original value from the untied object.
=head3 You cannot weaken a tied object
This is actually an unhandled reference by Perl (Verified with 5.9.2-). It means
that if you monitor (or tie explicitly) an object, any weaken references into
this one will simply be ignored.
=head4 Proof 01 : Basic test
+----------------------+
| Code |
+----------------------+
#!/usr/bin/perl
use Scalar::Util qw(weaken isweak);
my (@a, @b);
tie @a, 'Monitor::TestArray';
tie @b, 'Monitor::TestArray';
$a[0] = \@b;
$b[0] = \@a;
weaken($b[0]);
if (isweak($a[0])) {
print "\$a[0] is weak\n";
} else {
print "\$a[0] is not weak\n";
}
if (isweak($b[0])) {
print "\$b[0] is weak\n";
} else {
print "\$b[0] is not weak\n";
}
lib/Devel/Monitor.pm view on Meta::CPAN
+----------------------+
| Code |
+----------------------+
+------------+
| test.pl |
+------------+
#!/usr/bin/perl
use strict;
use warnings;
use Scalar::Util qw(weaken);
use Devel::Monitor qw(:all);
use Util::Junk;
my (@a, $b);
#tie @a, 'Devel::Monitor::TestArray';
$a[0] = \$b;
$b = \@a;
$a[1] = Util::Junk::_20M();
weaken($a[0]);
+------------+
| Util::Junk |
+------------+
package Util::Junk;
use strict;
use warnings;
sub _20M() { 'A 20 megs string here filled with zeros' }
lib/Devel/Monitor.pm view on Meta::CPAN
When @a is not tied (See the commented tie in test.pl), after loading the page like ten times, the
page will be in cache in every apache processes and other loading will be VERY fast. You'll also
notice that memory is stable.
However, if you uncomment the tie call in test.pl, you'll see your memory being filled to death and
every page loaded will be as long as at the beginning
=head4 Proof 03 : Final assault
Firstly, we must be sure that the methods Scalar::Util::weaken and Scalar::Util::isweak
doesn't contain bugs. The code for these method follows :
void
weaken(sv)
SV *sv
PROTOTYPE: $
CODE:
#ifdef SvWEAKREF
sv_rvweaken(sv);
#else
croak("weak references are not implemented in this release of perl");
#endif
void
isweak(sv)
SV *sv
PROTOTYPE: $
CODE:
#ifdef SvWEAKREF
lib/Devel/Monitor.pm view on Meta::CPAN
Let's see what result we should get :
+----------------------+
| Code |
+----------------------+
#!/usr/bin/perl
use strict;
use warnings;
use Devel::Monitor qw(:all);
use Scalar::Util qw(weaken);
use Devel::Peek;
{
my (@a);
$a[0] = \@a;
#tie @a, 'TestArray';
Dump($a[0],1);
weaken($a[0]);
Dump($a[0],1);
print "Leaving scope\n";
}
print "Scope left\n";
package TestArray;
use Tie::Array;
use base 'Tie::StdArray';
sub DESTROY { print "Monitor::TestArray::DESTROY : $_[0]\n"; }
lib/Devel/Monitor.pm view on Meta::CPAN
Monitor::TestArray::DESTROY : TestArray=ARRAY(0x8141354)
+----------------------+
| Explanations |
+----------------------+
Absolutely nothing has changed before and after. IT IS A PROBLEM ! So, I debugged
the perl source code to verify what happen with a tied variable. The method goes
like this :
/*
=for apidoc sv_rvweaken
Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
push a back-reference to this RV onto the array of backreferences
associated with that magic.
=cut
*/
SV *
Perl_sv_rvweaken(pTHX_ SV *sv)
{
SV *tsv;
if (!SvOK(sv)) /* let undefs pass */
return sv;
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
sv_add_backref(tsv, sv);
SvWEAKREF_on(sv);
SvREFCNT_dec(tsv);
return sv;
lib/Devel/Monitor.pm view on Meta::CPAN
//Do something here !!!
//***************************************
} else {
return sv;
}
This bug has been submitted and is unanswered for now. (See http://rt.perl.org/rt3/Ticket/Display.html?id=34524)
=head4 Conclusion
It is actually impossible to weaken a tied variable
=head1 TRICKS
=head2 Checking modules syntax
Since monitored are executed when you check syntax of a module, it will print out
to stderr some messages with constants and some global variables. So to remove
those prints, simple grep it by redirecting stderr to stdout and grep it
perl -c MyModule.pm 2>&1 | grep -iv '^(DESTROY|MONITOR|Scalar constant)'
t/Devel-Monitor.t view on Meta::CPAN
return 1;
}
#--------------------------------------------------------------------
# ClassA (Just a class with the "printSomething" method)
#--------------------------------------------------------------------
package ClassA;
use strict;
use warnings;
use Scalar::Util qw(weaken isweak);
sub new {
my ($class) = @_;
my $self = {};
bless($self => $class);
return $self;
}
sub getClassB {
my $self = shift;
t/Devel-Monitor.t view on Meta::CPAN
print "Something\n";
}
#--------------------------------------------------------------------
# ClassB (A class that got a "parent" which is a ClassA instance)
#--------------------------------------------------------------------
package ClassB;
use strict;
use warnings;
use Scalar::Util qw(weaken isweak);
sub new {
my ($class, $classA) = @_;
my $self = {};
bless($self => $class);
$self->setClassA($classA);
return $self;
}
sub setClassA {
( run in 0.251 second using v1.01-cache-2.11-cpan-65fba6d93b7 )