#! /usr/bin/perl
use strict;

my $list = new LinkedList(qw(software cheese fruit wine pasta));
print "Listing list forward:\n";
do {
  print "  Node: ", $list->data, "\n";
} while $list->move_next;
print "\nListing list backward:\n";
do {
  print "  Node: ", $list->data, "\n";
} while $list->move_prev;


package LinkedList;
use WeakRef;

sub add_next {
  my $self = shift;
  $self->{current}->add_next(LinkedList::Node->new(shift));
  return 1;
}

sub add_prev {
  my $self = shift;
  $self->{current}->add_prev(LinkedList::Node->new(shift));
  return 1;
}

sub clone {
  my $self = shift;
  my $clone = bless { %$self }, ref($self);
  my $is_clone = $self->{is_clone};
  $is_clone->{$clone} = $clone;
  weaken($is_clone->{$clone});
  return $clone;
}

sub data {
  (shift)->{current}->data;
}

sub move_next {
  my $self = shift;
  my $next = $self->{current}->next();
  $self->{current} = $next if defined($next);
  return defined($next);
}

sub move_prev {
  my $self = shift;
  my $prev = $self->{current}->prev();
  $self->{current} = $prev if defined($prev);
  return defined($prev);
}

sub new {
  my $class = shift;
  my $self = bless {}, $class;
  my $data = shift;
  $self->{current} = LinkedList::Node->new($data);
  $self->{is_clone} = {$self=>{$self}};
  weaken($self->{is_clone}->{$self});
  my $clone = $self->clone;
  while (@_) {
    $clone->add_next(shift);
    $clone->move_next;
  }
  return $self;
}

sub next {
  my $clone = (shift)->clone;
  $clone->move_next ? $clone : undef;
}

sub prev {
  my $clone = (shift)->clone;
  $clone->move_prev ? $clone : undef;
}

sub DESTROY {
  my $self = shift;
  #warn("Destroying linked list $self\n");
  delete $self->{is_clone}->{$self};
  if (not keys %{$self->{is_clone}}) {
    # Clean up circular stuff
    my $node = $self->{current};
    while (defined($node)) {
      $node = delete $node->{next};
    }
    $node = $self->{current};
    while (defined($node)) {
      $node = delete $node->{prev};
    }
  }
  #warn("Linked list $self destroyed\n");
}

package LinkedList::Node;

sub add_next {
  my ($self, $next) = @_;
  my $old_next = $self->{next};
  $self->{next} = $next;
  $next->{prev} = $self;
  $next->{next} = $old_next;
  $old_next->{prev} = $next if defined($old_next);
}

sub add_prev {
  my ($self, $prev) = @_;
  my $old_prev = $self->{prev};
  $self->{prev} = $prev;
  $prev->{next} = $self;
  $prev->{prev} = $old_prev;
  $old_prev->{next} = $prev if defined($old_prev);
}
  
sub data {
  (shift)->{data};
}

sub new {
  my ($class, $data) = @_;
  return bless { data => $data}, $class;
}

sub next {
  (shift)->{next};
}

sub prev {
  (shift)->{prev};
}

sub DESTROY {
  my $self = shift;
  #warn("Node: $self->{data} destroyed");
}
[download]