File Coverage

blib/lib/Devel/Monitor.pm

Criterion	Covered	Total	%
statement	222	270	82.2
branch	72	112	64.2
condition	8	18	44.4
subroutine	32	45	71.1
pod	0	3	0.0
total	334	448	74.5

package Devel::Monitor;

use 5.008006;
use strict;
use warnings;

require Exporter;
use AutoLoader qw(AUTOLOAD);

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration use Devel::Monitor ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.

our @EXPORT = qw();  #Export by default

our %EXPORT_TAGS = ( #Export as groups
    'all' => [
        qw(monitor
           print_circular_ref
        )
    ]
);

Exporter::export_ok_tags(    #Export by request (into @EXPORT_OK)
    'all');

our $VERSION = '0.9.0.7';

use Error qw(:try);
use Scalar::Util qw(isweak);
use Devel::Monitor::Common qw(:all);
use Devel::Monitor::Trace;
use Devel::Monitor::TraceItem;
use Devel::Monitor::Array;
use Devel::Monitor::Hash;
use Devel::Monitor::Scalar;

#Circular references type
use constant CRT_NONE              => undef;
use constant CRT_CIRC_REF          => 1;
use constant CRT_INTERNAL_CIRC_REF => 2;
use constant CRT_WEAK_CIRC_REF     => 3;

# METH monitor
#
# DESC Monitoring multiple variables
#      monitor('name for a' => \$a,
#              'name for b' => \$b,
#              'name for c' => \$c,
#              'name for d' => \@d,
#              'name for e' => \%e,
#              'name for F' => \&F);
# DESC Monitoring single constant variable (FOR INTERNAL USE ONLY)
#      monitor('name for F' => \&F, 1);
#      The last flag indicates that it is code reference

sub monitor {
    my $isCode;
    $isCode = pop if scalar(@_) % 2 != 0;
    my %values = @_;
    foreach my $key (keys %values) {
        my $varRef = $values{$key};
        if ($varRef) {  #If the value is undef
            _dereference(\$varRef);
            if ($varRef =~ /HASH/ ) {  #An hash object or an hash
                _tieHash($varRef,$key,$isCode);
            }
            elsif ($varRef =~ /SCALAR|REF/) {
                _tieScalar($varRef,$key,$isCode);
            }
            elsif ($varRef =~ /ARRAY/) {
                _tieArray($varRef,$key,$isCode);
            }
            elsif ($varRef =~ /CODE/) {
                ###########################################################
                # Info on constants
                ###########################################################
                # use constant CONST => [1,2];
                # print \&CONST."\n";
                # print &CONST."\n";
                # print \&CONST()."\n";
                # print &CONST()."\n";
                #
                # CODE(0x8203000)
                # ARRAY(0x81d4c04)
                # REF(0x820303c)
                # ARRAY(0x81d4c04)
                #
                # Code    Ref
                #   |      |
                # Array  Array
                #   |      |
                # +---+  +---+
                # |1,2|  |1,2|
                # +---+  +---+
                #
                ###########################################################
                # use constant CONST => 'a scalar';
                # print \&CONST."\n";
                # print &CONST."\n";
                # print \&CONST()."\n";
                # print &CONST()."\n";
                #
                # CODE(0x820300c)
                # a scalar
                # SCALAR(0x81fb2c4)
                # a scalar
                #
                #   Code        Scalar
                #     |            |
                # 'a scalar'  'a scalar'
                #
                # Instead of :
                #
                #   Code          Ref
                #     |            |
                #  Scalar       Scalar
                #     |            |
                # 'a scalar'  'a scalar'
                #
                ###########################################################
                if (ref(&$varRef) =~ /ARRAY|HASH/) {
                    _monitorRecursively($key => &$varRef);
                } else {
                    #_tieScalar($varRef);
                    Devel::Monitor::Common::printMsg("Scalar constant $key cannot be monitored\n");
                }
            }
            else {
                my $runPatch = 0;
                try {
                    _tieHash($varRef,$key);
                } otherwise {
                    ###########################################################
                    # Patch for Error.pm
                    # It seems there is a bug in this module
                    ###########################################################
                    # Example :
                    ###########################################################
                    # #!/usr/bin/perl
                    # use strict;
                    # use warnings;
                    # use Devel::Monitor;
                    # {
                    #     my @a = (1,2,3,4);
                    #     monitor('a'=>\@a);
                    #     print STDERR "Leaving scope\n";
                    # }
                    # print STDERR "Scope left\n";
                    ###########################################################
                    # Output without the patch (Very bad for mod_perl)
                    ###########################################################
                    # MONITOR ARRAY : a
                    # Leaving scope
                    # Scope left
                    # DESTROY ARRAY : a
                    ###########################################################
                    # Output with the patch (Ok)
                    ###########################################################
                    # MONITOR ARRAY : a
                    # Leaving scope
                    # DESTROY ARRAY : a
                    # Scope left
                    ###########################################################
                    $runPatch = 1;
                    #try {
                    #    _tieArray($varRef,$key);
                    #} otherwise {
                    #    Devel::Monitor::Common::printMsg("$varRef($key) cannot be monitored\n");
                    #};
                };
                if ($runPatch) {
                    try {
                        _tieArray($varRef,$key);
                    } otherwise {
                        Devel::Monitor::Common::printMsg("$varRef($key) cannot be monitored\n");
                    };
                }
            }
        }
    }
}

sub _monitorRecursively {
    my %values = @_;
    foreach my $key (keys %values) {
        my $varRef = $values{$key};
        if ($varRef) {  #If the value is undef
            _dereference(\$varRef);
            if ($varRef =~ /HASH/ ) {  #An hash object or an hash
                HASH_ITEM:
                foreach my $item (keys %$varRef) {
                    #print STDERR "ITEM : ".$varRef->{$item}."\n";
                    _monitorRecursively("$key {$item}" => \($varRef->{$item}));
                }
            }
            elsif ($varRef =~ /SCALAR/) {
                # nothing
            }
            elsif ($varRef =~ /ARRAY/) {
                ARRAY_ITEM:
                my $i = 0;
                foreach my $item (@$varRef) {
                    #print STDERR "ITEM : ".$item."\n";
                    _monitorRecursively("$key [$i]" => \$item);
                    $i++;
                }
            }
            elsif ($varRef =~ /CODE/) {
                # nothing
            }
            else {
                my $runPatch = 0;
                try {
                    goto HASH_ITEM;
                } otherwise {
                    $runPatch = 1;
                };
                if ($runPatch) {
                    try {
                        goto ARRAY_ITEM;
                    } otherwise {
                        #Devel::Monitor::Common::printMsg("$varRef($key) cannot be monitored recursively\n");
                        #we call monitor, this one will print the error
                    };
                }
            }
            # Finally, monitor current variable
            monitor($key => $varRef, 1);
        }
    }
}

sub _tieHash {
    my $varRef = shift;
    my $name = shift;
    my $isCode = shift;

    if (not tied %$varRef) {
        tie %$varRef, 'Devel::Monitor::Hash', $varRef, $name, $isCode;
    } else {
        my $self = tied %$varRef;
        #if tied by our Devel::Monitor
        if (ref($self) =~ /Devel::Monitor/) {
            Devel::Monitor::Common::printMsg("Hash from $name is already tied by ".$self->{Devel::Monitor::Common::F_ID()}."\n");
        } else {
            Devel::Monitor::Common::printMsg("Array from $name is already tied by the ".ref($self)." package\n");
        }
    }
}

sub _tieArray {
    my $varRef = shift;
    my $name = shift;
    my $isCode = shift;

    if (not tied @$varRef) {
        tie @$varRef, 'Devel::Monitor::Array', $varRef, $name, $isCode;
    } else {
        my $self = tied @$varRef;
        #if tied by our Devel::Monitor
        if (ref($self) =~ /Devel::Monitor/) {
            Devel::Monitor::Common::printMsg("Array from $name is already tied by ".$self->{Devel::Monitor::Common::F_ID()}."\n");
        } else {
            Devel::Monitor::Common::printMsg("Array from $name is already tied by the ".ref($self)." package\n");
        }
    }
}

sub _tieScalar {
    my $varRef = shift;
    my $name = shift;
    my $isCode = shift;

    if (not tied $$varRef) {
        try {
            tie $$varRef, 'Devel::Monitor::Scalar', $varRef, $name, $isCode;
        } otherwise {
            Devel::Monitor::Common::printMsg("Scalar from $name is read-only, monitor skipped\n");
        };
    } else {
        my $self = tied $$varRef;
        #if tied by our Devel::Monitor
        if (ref($self) =~ /Devel::Monitor/) {
            Devel::Monitor::Common::printMsg("Scalar from $name is already tied by ".$self->{Devel::Monitor::Common::F_ID()}."\n");
        } else {
            Devel::Monitor::Common::printMsg("Array from $name is already tied by the ".ref($self)." package\n");
        }
    }
}

#Not used
# sub unmonitor {
    # my @varsRef = @_;
    # foreach my $varRef (@varsRef) {
        # if ($varRef) {
            # _dereference(\$varRef);
            # if ($varRef =~ /HASH/ ) {  #An object or an hash
                # Devel::Monitor::Hash::unmonitor($varRef);
            # }
            # elsif ($varRef =~ /SCALAR/) {
                # Devel::Monitor::Scalar::unmonitor($varRef);
            # }
            # elsif ($varRef =~ /ARRAY/) {
                # Devel::Monitor::Array::unmonitor($varRef);
            # }
            # elsif ($varRef =~ /CODE/) {
                # unmonitor(&$varRef); #TODO : Unmonitor recursively, do not touch scalars
            # }
            # else {
                # my $runPatch = 0;
                # try {
                    # Devel::Monitor::Hash::unmonitor($varRef);
                # } otherwise {
                    # $runPatch = 1;
                # };
                # if ($runPatch) {
                    # try {
                        # Devel::Monitor::Array::unmonitor($varRef);
                    # } otherwise {
                         # Devel::Monitor::Common::printMsg("$varRef cannot be unmonitored\n");
                    # };
                # }
            # }
        # }
    # }
# }

sub _dereference {
    my $varRefRef = shift;
    my $type = ref($$varRefRef);
    #print STDERR "VARIABLE : $$varRefRef\n";
    #print STDERR "TYPE     : $type\n";
    ##############################################################
    # You need to dereference, otherwise, you may
    # get this error : Modification of a read-only value attempted
    # is you monitor a variable that use a constant by example
    ##############################################################
    while ($type =~ /REF/) {
        $$varRefRef = $$$varRefRef;
        $type = ref($$varRefRef);
        #print STDERR "V        : $$varRefRef\n";
        #print STDERR "T        : $type\n";
    }
}

# METH printCircularRef
#
# DESC Try to find circular references and print it out into STDERR

#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");
                Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
                _printCircularRefResults($varRef,$circRefTypesRef);
            } else {
                push(@$circRefTypesRef, CRT_INTERNAL_CIRC_REF());
                Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
                Devel::Monitor::Common::printMsg('Internal circular reference on scalar(s) starting at : '.$trace->getCircularPath()."\n");
                $trace->dump();
                Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
            }
            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
            #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) {
            try {
                goto ARRAY_ITEM;
            } otherwise {
                die("Cannot verify circular references for $varRef of type ".ref($varRef)."\n");
            };
        }
    }
}

sub _printCircularRefHeader {
    my $origRef = shift;

    Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
    Devel::Monitor::Common::printMsg("Checking circular references for $origRef\n");
}

sub _printCircularRefResults {
    my ($origRef, $circRefTypesRef) = @_;

    my $circRefsCount = 0;
    my $internalCircRefsCount = 0;
    my $weakCircRefsCount = 0;
    foreach my $crt (@$circRefTypesRef) {
        $weakCircRefsCount++ if $crt == CRT_WEAK_CIRC_REF();
        $circRefsCount++ if $crt == CRT_CIRC_REF();
        $internalCircRefsCount++ if $crt == CRT_INTERNAL_CIRC_REF();
    }
    Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
    Devel::Monitor::Common::printMsg("Results for $origRef\n");
    Devel::Monitor::Common::printMsg("Circular reference          : $circRefsCount\n");
    Devel::Monitor::Common::printMsg("Internal circular reference : $internalCircRefsCount\n");
    Devel::Monitor::Common::printMsg("Weak circular reference     : $weakCircRefsCount\n");
    Devel::Monitor::Common::printMsg("-------------------------------------------------------------------------------\n");
}

# 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();
                }
            }
        }
        return CRT_NONE();
    }
    die("_checkCircularRef : \$varRef is undefined\n");
}

sub _addSeenRef {
    my $varRef = shift;
    my $seenRef = shift;
    #print STDERR "_addSeenRef: $varRef\n";
    if (exists($seenRef->{$varRef})) {
        $seenRef->{$varRef}++;
    } else {
        $seenRef->{$varRef} = 1;
    }
}

sub _getVarRef {
    my $varRef = shift;
    ###########################################################
    # We cannot use tied objects because it reuse memory space
    ###########################################################
    # use Tie::Hash;
    #
    # my $self = {'a' => 1,
    #             'b' => 2};
    # #monitor('self' => \$self);
    # tie %$self, 'Tie::StdHash';
    # print STDERR \($self->{'a'})."\n";
    # print STDERR \($self->{'b'})."\n";
    # print STDERR \($self->{'a'}).\($self->{'b'})."\n";
    # foreach my $key (keys %$self) {
    #     my $keyRef = \$key;
    #     my $value = $self->{$key};
    #     my $valueRef = \($self->{$key});
    #     print STDERR "KEY:$key, KEY REF:$keyRef, VALUE:$value, VALUE REF:$valueRef\n";
    # }
    ###########################################################
    # Output
    ###########################################################
    # MONITOR HASH : self
    # SCALAR(0x8141384)
    # SCALAR(0x8141384)
    # SCALAR(0x8141384)SCALAR(0x81413cc)
    # KEY:a, KEY REF:SCALAR(0x8141420), VALUE:1, VALUE REF:SCALAR(0x824becc)
    # KEY:b, KEY REF:SCALAR(0x81413cc), VALUE:2, VALUE REF:SCALAR(0x824becc)
    # DESTROY HASH : self
    ###########################################################
    # We see clearly that it reuse memory space instead of
    # refering to the original values from the untied object
    ###########################################################
    my $ref;
    #if ($$varRef &&
    #    ($varRef =~ /SCALAR/) &&
    #    ($$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__