Getopt::LL::DLList

# $Id: DLList.pm,v 1.9 2007/07/13 00:00:14 ask Exp $
# $Source: /opt/CVS/Getopt-LL/lib/Getopt/LL/DLList.pm,v $
# $Author: ask $
# $HeadURL$
# $Revision: 1.9 $
# $Date: 2007/07/13 00:00:14 $
package Getopt::LL::DLList;
use strict;
use warnings;
use Carp qw(croak);
use Getopt::LL::DLList::Node;
use Scalar::Util qw();
#use Class::InsideOut::Policy::Modwheel qw( :std );
use version; our $VERSION = qv('1.0.0');
use 5.006_001;
{

    use Class::Dot qw( property isa_Object );

    property head => isa_Object();

    sub new {
        my ($class, $array_ref) = @_;

        if ($array_ref && !_ARRAYLIKE($array_ref)) {
            croak 'Argument to Getopt::LL::DLList must be array reference.';
        }

        my $self = bless { }, $class;

        $self->_init($array_ref);

        return $self;
    }

    sub _init {
        my ($self, $array_ref) = @_;
        return if not ref $array_ref;
        return if not scalar @{$array_ref};

        my $prev_node   = Getopt::LL::DLList::Node->new();
        my $list_head   = $prev_node;

        for my $array_element (@{$array_ref}) {

            $prev_node->set_data($array_element);

            my $next_node = Getopt::LL::DLList::Node->new();
            $prev_node->set_next($next_node);
            $next_node->set_prev($prev_node);
            $prev_node = $next_node;

        }

        # last node is always empty, so delete it.
        $prev_node->prev->set_next(undef);
        $prev_node->free();

        $self->set_head($list_head);

        return;
    }

    sub traverse {
        my ($self, $handler_object, $handler_method) = @_;
        my $dll    = $self->head;

        my $current_node    = $dll;
        my $nodes_so_far    = 0;
        while ($current_node) {
            $handler_object->$handler_method($current_node->data,
                $current_node,$nodes_so_far++);

            $current_node = $current_node->next;
        }

        return $nodes_so_far;
    }

    sub delete_node {
        my ($self, $node) = @_;
        return if not $node;

        my $node_data = $node->data;

        my $prev_node = $node->prev;
        my $next_node = $node->next;

        if ($prev_node) {
            $prev_node->set_next($next_node);
        }
        else {
            $self->set_head($next_node);
        }

        if ($next_node) {
            $next_node->set_prev($prev_node);
        }

        $node->free;

        return $node_data;
    }

    sub DEMOLISH {
        my ($self) = @_;
        my $head = $self->head;
        if ($head) {
            $head->free();
        }
        undef $self->{__x__head__x__}; # << Class::Dot 1.0 weirdness.
        undef $self->{head};
        return;
    }

    # Taken from Params::Util
    sub _ARRAYLIKE { ## no critic

        (defined $_[0] and ref $_[0] and (
        (Scalar::Util::reftype($_[0]) eq 'ARRAY')
        or
        overload::Method($_[0], '@{}')
        )) ? $_[0] : undef;
    }
}
1;

__END__