comment on

I've run into a problem with perl's reference count-based garbage collection that I cannot figure out. What I've got is a directed graph that fails to be destroyed prior to the global destruction phase that occurs when the interpreter exits. The problem arises (AFAICT) only when doing a depth first search through the graph. Since this is the backend to a mod_perl-based CGI, clearly I need timely destruction of the objects and cannot rely on the interpreter's exit. At this point I think it's something due to the way perl handles lexical pads in recursive method calls, but I don't get why. I've distilled the problem down by borrowing TheDamian's graph code from Object Oriented Perl pgs 108-14 and adding my DFS routine and some debugging stuff. The code should run as is, although the full version requires Data::Structure::Util. My bleeding brain thanks you.

use strict;
use warnings;
# Uncomment if you have this.
#use Data::Structure::Util(qw/has_circular_ref circular_off/);

# BEGIN NETWORK CLASS
package Network;

sub new
  {
    my ($class) = @_;
    bless { _nodes => [] }, $class;
  }

sub node
  {
    my ($self, $index) = @_;
    return $self->{_nodes}[$index];
  }

sub add_node
  {
    my ($self) = @_;
    push @{$self->{_nodes}}, Node->new();
  }

# CAUSE OF THE TROUBLE
sub DFS
  {
    my ($self, $node, $sub) = @_;

    my ($explored, $do_search);
    
    $do_search =  sub {

      my ($node) = @_;
      $sub->($node);
      $explored->{$node->{_id}}++;
      foreach my $link (@{$node->{_outlinks}}) {
    $do_search->($link->{_to}) unless ($explored->{$link->{_id}});
      }
    };
    $do_search->($node);
  }

sub transitive_closure_DFS
  {
    my ($self, $node) = @_;
    my $nodes = [];
    my $search = sub { push @$nodes, $_[0] };
    $self->DFS($node, $search);
    return $nodes;
  }

sub DESTROY 
  {
    my ($self) = @_;
    print "DESTROYING $self\n";
    foreach my $node (@{$self->{_nodes}}) {
      $node->delete_links();
    }
  }
  
# BEGIN NODE CLASS
package Node;

{ 
  my $_nodecount = 0;
  sub _nextID { return ++$_nodecount }
}

sub new
  {
    my ($class) = @_;
    bless { _id => _nextID(), _outlinks => [] }, $class;
  }

sub add_link_to
  {
    my ($self, $target) = @_;
    push @{$self->{_outlinks}}, Link->new($target);
  }

sub delete_links
  {
    my ($self) = @_;
    delete $self->{_outlinks};
  }

sub DESTROY 
  {
    my ($self) = @_;
    print "DESTROYING $self $self->{_id}\n";
  }

# BEGIN LINK CLASS
package Link;

{ 
  my $_linkcount = 0;
  sub _nextID { return ++$_linkcount }
}

sub new
  {
    my ($class, $target) = @_;
    bless { _id => _nextID(),
        _to => $target 
      }, $class;
  }

sub delete_node
  {
    my ($self) = @_;
    delete $self->{_to};
  }

sub DESTROY 
  {
    my ($self) = @_;
    print "DESTROYING $self $self->{_id}\n";
    $self->delete_node(); # EVEN THIS DOESN'T KILL THE REMAINING NODES
  }


package main;

sub build_graph
  {
    my $network = Network->new();
    
    for (0..2) { $network->add_node(); }
    $network->node(0)->add_link_to($network->node(1));
    $network->node(0)->add_link_to($network->node(2));
    $network->node(1)->add_link_to($network->node(2));
    $network->node(2)->add_link_to($network->node(1));
    my $neighbors = $network->transitive_closure_DFS($network->node(0)
+);
    print "Neighbors\n";
    print "  $_ ID $_->{_id}\n" for (@$neighbors);

# Uncomment if you have the module
#    circular_off($network); # THIS DOES NOT AFFECT BEHAVIOR, WHY?
  }

print "BUILDING GRAPH\n";
build_graph();
print "SHOULD BE THE LAST THING PRINTED, HOWEVER ...\n";
__END__
[download]

This yields:

BUILDING GRAPH
Neighbors
  Node=HASH(0x104fbc) ID 1
  Node=HASH(0xfc450) ID 3
  Node=HASH(0xfc414) ID 2
DESTROYING Network=HASH(0xfc04c)
DESTROYING Link=HASH(0xfc498) 2
DESTROYING Link=HASH(0xfc438) 1
DESTROYING Link=HASH(0xfc4c8) 3
DESTROYING Link=HASH(0xfc4f8) 4
SHOULD BE THE LAST THING PRINTED, HOWEVER ...
DESTROYING Node=HASH(0xfc414) 2
DESTROYING Node=HASH(0x104fbc) 1
DESTROYING Node=HASH(0xfc450) 3
[download]


Keep It Simple, Stupid
	PerlMonks