view release on metacpan or  search on metacpan

t/Devel-Monitor.t  view on Meta::CPAN

     |   /   \/   \
     |  c<---d     h<--|
     | /            \  |
     e              i--|

     Note : Vertical lines goes up
     
     # Starting with _classB
     a,b,c,e,a (Loop on a)
     a,b,c,e,b (Loop on b)
     a,b,a     (Loop on a)
     a,b,d,e,a (Loop on a)
     a,b,d,e,b (Loop on b)
     # Starting with A1
     a,b,c,e,a (Loop on a)
     a,b,c,e,b (Loop on b)
     a,b,a     (Loop on a)
     a,b,d,e,a (Loop on a)
     a,b,d,e,b (Loop on b)
     # Starting with A2
     a,g,d,c,e,a     (Loop on a)
     a,g,d,c,e,b,c   (Loop on c)
     a,g,d,c,e,b,a   (Loop on a)
     a,g,d,c,e,b,d,c (Loop on c)
     a,g,h,i,h       (Loop on h)

=cut

sub testPCR {
    my $a = ClassA->new();
    my $b = $a->getClassB();
    my ($c, $d, @e, @f, %g, $h, $i);
    $a->{A1} = \$b;
    $a->{A2} = \%g;
    $b->{B1} = \$c;
    $b->{B2} = \$d;
    $c = \@e;
    $e[0] = \$a; 
    $e[1] = \$b; 
    $d = \$c;     
    $g{G1} = \$d; 
    $g{G2} = \$h;
    $h = \$i;
    $i = \$h;
    print_circular_ref(\$a);
    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;
    $self->{_classB} = ClassB->new($self);
    return $self->{_classB};
}
 
sub printSomething {
    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 {
    my ($self, $classA) = @_;
    $self->{_classA} = $classA;
}
 
sub getClassA {
    return shift->{_classA};
}