[perl #25237] Memory Leak when Recursively Traversing Circular Datastructures

# New Ticket Created by  (David Jantzen) 
# Please include the string:  [perl #25237]
# in the subject line of all future correspondence about this issue. 
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=25237 >


This is a bug report for perl from djantzen@indiana.edu,
generated with the help of perlbug 1.33 running under perl v5.6.1.


-----------------------------------------------------------------
[Please enter your report here]

The full post and discussion can be found at:

  http://perlmonks.org/index.pl?node_id=319780

Further details are here:

  http://perlmonks.org/index.pl?node_id=320069

I've managed to solve my own issues by making the problem subroutines
into iterative functions rather than recursive, but others may yet be
bitten. 

Code demonstrating the bug follows:

use strict;
use warnings;
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);

    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__




[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
    category=core
    severity=medium
---
Site configuration information for perl v5.6.1:

Configured by stassenm at Wed Dec 12 22:46:50 EST 2001.

Summary of my perl5 (revision 5.0 version 6 subversion 1) configuration:
  Platform:
    osname=solaris, osvers=2.7, archname=sun4-solaris
    uname='sunos bell 5.7 generic_106541-16 sun4u sparc sunw,ultra-250 '
    config_args='-Dcc=gcc -Dprefix=/usr/local'
    hint=recommended, useposix=true, d_sigaction=define
    usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
    useperlio=undef d_sfio=undef uselargefiles=define usesocks=undef
    use64bitint=undef use64bitall=undef uselongdouble=undef
  Compiler:
    cc='gcc', ccflags ='-fno-strict-aliasing -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-O2',
    cppflags='-fno-strict-aliasing -I/usr/local/include'
    ccversion='', gccversion='2.95.2 19991024 (release)', gccosandvers='solaris2.7'
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=4321
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=16
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=8, usemymalloc=y, prototype=define
  Linker and Libraries:
    ld='gcc', ldflags =' -L/usr/local/lib '
    libpth=/usr/local/lib /usr/lib /usr/ccs/lib
    libs=-lsocket -lnsl -ldl -lm -lc
    perllibs=-lsocket -lnsl -ldl -lm -lc
    libc=/lib/libc.so, so=so, useshrplib=false, libperl=libperl.a
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags=' '
    cccdlflags='-fPIC', lddlflags='-G -L/usr/local/lib'

Locally applied patches:
    

---
@INC for perl v5.6.1:
    /usr/local/lib/perl5/5.6.1/sun4-solaris
    /usr/local/lib/perl5/5.6.1
    /usr/local/lib/perl5/5.6.1/site_perl/sun4-solaris
    /usr/local/lib/perl5/5.6.1/site_perl
    /usr/local/lib/perl5/5.6.1/site_perl
    .

---
Environment for perl v5.6.1:
    HOME=/home/djantzen
    LANG (unset)
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/djantzen/kb3/bin:/home/djantzen/kb3/adm:/home/djantzen/kb3/janis/bin:/usr/local/bin:/usr/bin:/usr/dt/bin:/usr/X/bin:/opt/NSCPcom:/usr/ccs/bin:/opt/krb5/bin:/kb/bin:/kb/adm:/oracle/app/oracle/product/8.1.7/bin:/home/djantzen/bin:/opt/ORBacus/bin:/usr/sbin:/usr/oasys/bin/:/home/djantzen/kb3/Panoply/bin:/home/djantzen/bin:/opt/ORBacus/bin:/usr/sbin:/usr/oasys/bin/:/home/djantzen/kb3/Panoply/bin:/home/djantzen/kb3/adm/dev/apache/bin
    PERL_BADLANG (unset)
    SHELL=/usr/local/bin/bash

• [perl #25237] Memory Leak when Recursively Traversing Circular Datastructures by perlbug-followup
• Re: [perl #25237] Memory Leak when Recursively Traversing Circular Datastructures by Dave Mitchell