my $dad= My::Parent->new( name => 'Robert' );
    {
        my $son= My::Child->new( $dad, name => 'Bobby' );
    }
    # No direct access to Bobby at this point.
    # That triggers garbage collection.
    # Bobby and Robert circularly reference each other.
    # Robert is still reachable from the outside.
    # Bobby does not get destroyed, because we can reach him indirectly:
    {
        my $son= $dad->GetSon();    # Got Bobby again
    }

    $dad= My::Parent->new( name => 'Walter' );
    # No direct access to Robert, now.  Garbage collection runs.
    # Robert and Bobby form a loop but both are unreferenced.
    # Both get destroyed.

##</code><code>##

package My::Parent;
use My::Outer qw< ::Inner new DESTROY AUTOLOAD >;
use overload '""' => \&GetName;

package My::Child;
use My::Outer qw< ::Inner new DESTROY AUTOLOAD >;
use overload '""' => \&GetName;

##</code><code>##

package My::Inner;

# Usage:  use My::Inner qw< _wrap _unwrap _incRefs _decRefs >;
# Defines the using class as an inner class wrapped by some other class
# (the wrapping class must use My::Outer).
# The using class must define the following methods:
#     _new:   the constructor
#     _free:  breaks ref cycles if all related inner objects are unref'd
#+    _incRefs: increments inner object's ref count
#+    _decRefs: decrements inner object's ref count, returning result
#+ If using class creates blessed hashes and wants $obj->{refs} to be the ref
#+ count, then it can just import the _incRefs and _decRefs methods.
##  (Not: "Using class must create blessed hashes so $obj->{ref},
##  $obj->{wrapper} work.")

use Exporter 'import';
BEGIN { our @EXPORT_OK= qw< _wrap _unwrap _incRefs _decRefs >; }

sub _wrap {
    my( $in, $class )= @_;
    my $out= bless \$in, $class;
    $in->_incRefs();
    ##  if(  $class  ) {
    ##      $in->{wrapper}= $class
    ##  } else {
    ##      $class= $in->{wrapper};
    ##  }
    return $out;
}

sub _unwrap {
    my( $in )= @_;
    if(  ! $in->_decRefs()  ) {
        $in->_free();
    }
}

#+ (Added below code)
sub _incRefs {
    my( $in )= @_;
    $in->{refs}++;
}

sub _decRefs {
    my( $in )= @_;
    return --$in->{refs};
}

##</code><code>##

# Outer objects:   dad          son  These are wrappers given to others
#                   |            |   just to track what is still in-use.
#                   v            v
# Inner objects:  _dad <------ _son  These have the real data, including
#                   `------------^   links to other (inner) objects.

##</code><code>##

package My::Child::Inner;
use My::Inner qw< _wrap _unwrap _incRefs _decRefs >;

sub _new {
    my( $class, $dad, @args )= @_;
    # Replace this with your real constructor!
    my $_son= { name => 'Boy', @args };
    bless $_son, $class;
    $$dad->_adopt( $_son )
        if  $dad;
    return $_son;
}

sub GetName {
    my( $_son )= @_;
    return $_son->{name};
}

sub GetDad {
    my( $_son )= @_;
    my $_dad= $_son->{dad};
    return undef
        if  ! $_dad;
    # We must wrap objects returned from public methods!
    return $_dad->_wrap();
}

# For debugging:
sub DESTROY {
    my( $_son )= @_;
    warn "DESTROYing son: $_son->{name}\n";
}

##</code><code>##

# Called when Son is no longer externally referenced:
sub _free {
    my( $_son )= @_;
    my $_dad= $_son->{dad};
    if(  ! $_dad  ||  ! $_dad->{refs}  ) {
        # Son can die (and take Dad with him)
        # if there is no Dad (or Dad is also unreferenced):
        $_son->{dad}= $_dad->{son}= undef;  # Break ref cycles!
    }
}

##</code><code>##

sub _isRefd {
    my( $_son, $hvSeen )= @_;
    $hvSeen ||= {};
    return 0    # Let first call decide, since we've
        if  $hvSeen->{0+$_son}++;   # circled back to ourselves.
    return 1
        if  $_son->{refs};
    my $dads= $_son->{dads};
    for my $_dad (  @$dads  ) {
        return 1
            if  $_dad->isRefd($hvSeen);
    }
    return 0;
}

##</code><code>##

sub _free {
    my( $_son, $force )= @_;
    return
        if  ! $force  &&  $_son->isRefd();
    my $dads= $_son->{dads};
    for my $_dad (  @$dads  ) {
        $_dad->_free( 1 );  # No need to check _isRefd() again.
    }
    $_son->{dads}= [ ];
}

##</code><code>##

{
    my $dad= My::Parent->new( name => 'Sr' );
    warn "\$dad=$dad\n";
    my $son= My::Child->new( $dad, name => 'Jr' );
    warn "\$dad=$dad -> \$son=$son\n";
    $dad= My::Parent->new( name => 'Newt' );
    warn "\$dad=$dad; Sr -> \$son=$son\n";
    warn "Sr no longer referenced, but not destroyed yet.\n";
    $dad->Adopt( $son );
    warn "\$dad=$dad -> \$son=$son; (Sr destroyed)\n";
    My::Child->new( $dad, name => 'Young' );
    warn "Young never really referenced, but not destroyed yet.\n";
    warn "\$dad=$dad -> Young; \$son=$son\n";
    $dad= My::Parent->new( name => 'Fin' );
    warn "\$dad=$dad; \$son=$son (Newt -> Young destroyed)\n";
    warn "Rest to be destroyed next.\n";
}
warn "Everything destroyed above.\n";

##</code><code>##

$dad=Sr
$dad=Sr -> $son=Jr
$dad=Newt; Sr -> $son=Jr
Sr no longer referenced, but not destroyed yet.
DESTROYing dad: Sr
$dad=Newt -> $son=Jr; (Sr destroyed)
Young never really referenced, but not destroyed yet.
$dad=Newt -> Young; $son=Jr
DESTROYing son: Young
DESTROYing dad: Newt
$dad=Fin; $son=Jr (Newt -> Young destroyed)
Rest to be destroyed next.
DESTROYing son: Jr
DESTROYing dad: Fin
Everything destroyed above.

##</code><code>##

#!/usr/bin/perl -w
use strict;

# Outer objects:   dad          son  These are wrappers given to others
#                   |            |   just to track what is still in-use.
#                   v            v
# Inner objects:  _dad <------ _son  These have the real data, including
#                   `------------^   links to other (inner) objects.


# Allow this mock-up to be run from a single file:
BEGIN { $INC{'My/Outer.pm'}= $INC{'My/Inner.pm'}= __FILE__; }


package My::Outer;

# Usage:  use My::Outer qw< ::Inner new DESTROY AUTOLOAD >;
# Defines the using class as an outer wrapper for the named inner class.
# The inner class must use My::Inner.

sub import {
    my( $class, $inner, @methods )= @_;
    my $outer= caller();
    $inner= $outer . $inner
        if  $inner =~ /^::/;
    for my $meth (  @methods  ) {
        my $sub= *{ _getGlob( __PACKAGE__, "__$meth" ) }{CODE};
        die __PACKAGE__, " does not export $meth"
            if  ! defined $sub;
        *{ _getGlob( $outer, $meth ) }= sub { $sub->( $inner, @_ ) };
    }
}

sub _getGlob
{
    my( $pkg, $name )= @_;
    my $stash= do { no strict 'refs'; \%{$pkg.'::'} };
    my $glob= \$stash->{$name};
    if(  'GLOB' ne ref $glob  ) {
        { no strict 'refs'; ${$pkg.'::'.$name}= undef; }
        $glob= \$stash->{$name};
        die "Can't coerce optimized STAB entry ($pkg\::$name) into real GLOB"
            if  'GLOB' ne ref $glob;
    }
    return $glob;
}

# Gets exported to 'inner' class as 'new' method:
sub __new {
    my( $inner, $class )= splice @_, 0, 2;
    return $inner->_new( @_ )->_wrap( $class );
}

# Gets exported to 'inner' class as 'DESTROY' method:
sub __DESTROY {
    my( $inner, $out )= @_;
    my $in= $$out;
    $in->_unwrap();
}

# Gets exported to 'inner' class as 'AUTOLOAD' method:
our $AUTOLOAD;
sub __AUTOLOAD {
    my( $inner, $out )= splice @_, 0, 2;
    my( $outer, $method )= $AUTOLOAD =~ /^(.+)(?:'|::)(.+)$/
        or  die "Invalid method name: $AUTOLOAD";
    die "Can't call internal method, $method, via external wrapper, $outer"
        if  $method =~ /^_/;
    my $in= $$out;
    return $in->$method( @_ );
}


package My::Inner;

# Usage:  use My::Inner qw< _wrap _unwrap _incRefs _decRefs >;
# Defines the using class as an inner class wrapped by some other class
# (the wrapping class must use My::Outer).
# The using class must define the following methods:
#     _new:     the constructor
#     _free:    breaks ref cycles if all related inner objects are unref'd
#     _incRefs: increments inner object's ref count
#     _decRefs: decrements inner object's ref count, returning result
# If using class creates blessed hashes and wants $obj->{refs} to be the ref
# count, then it can just import the _incRefs and _decRefs methods.

use Exporter 'import';
BEGIN { our @EXPORT_OK= qw< _wrap _unwrap _incRefs _decRefs >; }

sub _wrap {
    my( $in, $class )= @_;
    my $out= bless \$in, $class;
    $in->_incRefs();
    return $out;
}

sub _unwrap {
    my( $in )= @_;
    if(  ! $in->_decRefs()  ) {
        $in->_free();
    }
}

sub _incRefs {
    my( $in )= @_;
    $in->{refs}++;
}

sub _decRefs {
    my( $in )= @_;
    return --$in->{refs};
}

package My::Parent;
use My::Outer qw< ::Inner new DESTROY AUTOLOAD >;
use overload '""' => \&GetName;


package My::Child;
use My::Outer qw< ::Inner new DESTROY AUTOLOAD >;
use overload '""' => \&GetName;


package My::Parent::Inner;
use My::Inner qw< _wrap _unwrap _incRefs _decRefs >;

sub _new {
    my( $class, @args )= @_;
    # Replace this with your real constructor!
    my $_dad= { name => 'Pop', @args };
    return bless $_dad, $class;
}

sub Adopt {
    my( $_dad, $son )= @_;
    $_dad->_adopt( $son ? $$son : undef );
    return $son;
}

sub _adopt {
    my( $_dad, $_son )= @_;
    # Orphan $_dad's current son (if any):
    for my $_orphan (  $_dad->{son}  ) {
        $_orphan->{dad}= undef
            if  $_orphan;
    }
    if(  $_son  ) {
        # Take custody away from new son's prior dad, if any:
        for my $_sire (  $_son->{dad}  ) {
            $_sire->{son}= undef
                if  $_sire;
        }
        $_son->{dad}= $_dad;
    }
    $_dad->{son}= $_son;
    return $_son;
}

sub GetName {
    my( $_dad )= @_;
    return $_dad->{name};
}

sub GetSon {
    my( $_dad )= @_;
    my $_son= $_dad->{son};
    return undef
        if  ! $_son;
    # We must wrap objects returned from public methods!
    return $_son->_wrap();
}

# Called when Dad is no longer externally referenced:
sub _free {
    my( $_dad )= @_;
    my $_son= $_dad->{son};
    if(  ! $_son  ||  ! $_son->{refs}  ) {
        # Murder/suicide pact:
        $_son->{dad}= $_dad->{son}= undef;  # Break ref cycles!
    }
}

# For debugging:
sub DESTROY {
    my( $_dad )= @_;
    warn "DESTROYing dad: $_dad->{name}\n";
}


package My::Child::Inner;
use My::Inner qw< _wrap _unwrap _incRefs _decRefs >;

sub _new {
    my( $class, $dad, @args )= @_;
    # Replace this with your real constructor!
    my $_son= { name => 'Boy', @args };
    bless $_son, $class;
    $$dad->_adopt( $_son )
        if  $dad;
    return $_son;
}

sub GetName {
    my( $_son )= @_;
    return $_son->{name};
}

sub GetDad {
    my( $_son )= @_;
    my $_dad= $_son->{dad};
    return undef
        if  ! $_dad;
    # We must wrap objects returned from public methods!
    return $_dad->_wrap();
}

# For debugging:
sub DESTROY {
    my( $_son )= @_;
    warn "DESTROYing son: $_son->{name}\n";
}

# Called when Son is no longer externally referenced:
sub _free {
    my( $_son )= @_;
    my $_dad= $_son->{dad};
    if(  ! $_dad  ||  ! $_dad->{refs}  ) {
        # Son can die (and take Dad with him)
        # if there is no Dad (or Dad is also unreferenced):
        $_son->{dad}= $_dad->{son}= undef;  # Break ref cycles!
    }
}


package main;

{
    my $dad= My::Parent->new( name => 'Sr' );
    warn "\$dad=$dad\n";
    my $son= My::Child->new( $dad, name => 'Jr' );
    warn "\$dad=$dad -> \$son=$son\n";
    $dad= My::Parent->new( name => 'Newt' );
    warn "\$dad=$dad; Sr -> \$son=$son\n";
    warn "Sr no longer referenced, but not destroyed yet.\n";
    $dad->Adopt( $son );
    warn "\$dad=$dad -> \$son=$son; (Sr destroyed)\n";
    My::Child->new( $dad, name => 'Young' );
    warn "Young never really referenced, but not destroyed yet.\n";
    warn "\$dad=$dad -> Young; \$son=$son\n";
    $dad= My::Parent->new( name => 'Fin' );
    warn "\$dad=$dad; \$son=$son (Newt -> Young destroyed)\n";
    warn "Rest to be destroyed next.\n";
}
warn "Everything destroyed above.\n";

__END__

$dad=Sr
$dad=Sr -> $son=Jr
$dad=Newt; Sr -> $son=Jr
Sr no longer referenced, but not destroyed yet.
DESTROYing dad: Sr
$dad=Newt -> $son=Jr; (Sr destroyed)
Young never really referenced, but not destroyed yet.
$dad=Newt -> Young; $son=Jr
DESTROYing son: Young
DESTROYing dad: Newt
$dad=Fin; $son=Jr (Newt -> Young destroyed)
Rest to be destroyed next.
DESTROYing son: Jr
DESTROYing dad: Fin
Everything destroyed above.