File Coverage

blib/lib/LinkedList/Single.pm

Criterion	Covered	Total	%
statement	99	208	47.6
branch	20	68	29.4
condition	5	22	22.7
subroutine	21	41	51.2
pod	28	32	87.5
total	173	371	46.6

########################################################################
# housekeeping
########################################################################

package LinkedList::Single;

use v5.16;

use Carp;

use Scalar::Util    qw( blessed refaddr reftype looks_like_number );
use Symbol;

use overload
(
    q{bool} =>
    sub
    {
        # the list handler is true if the current
        # node is not empty (i.e., is not at the
        # final node).
        #
        # this allows for:
        #
        # $listh->head; while( $listh ){ ... }

        my $listh   = shift;

        $$listh # && @{ $$listh }
    },

    # return a node at the given offset.
    # update the list to that point.

    q{+} =>
    sub
    {
        my ( $listh, $offset )
        = $_[2]
        ? @_[1,0]
        : @_[0,1]
        ;

        my $node    = $$listh || $listh->head_node;

        # i.e., $offset == 0, gets ( 1 .. 0 ) for no change.

        for ( 1 .. $offset )
        {
            $node or last;

            $node       = $node->[0];
        }

        $node
    },

    q{+=} =>
    sub
    {
        my ( $listh, $offset )
        = $_[2]
        ? @_[1,0]
        : @_[0,1]
        ;

        $$listh = $listh + $offset;

        $listh
    },

);

########################################################################
# package variables
########################################################################

our $VERSION = '1.02';
$VERSION = eval $VERSION;

# inside-out data for the heads of the lists.

my %rootz   = ();

########################################################################
# utility subs
########################################################################

########################################################################
# perl's recursive cleanups is no longer an issue after 5.16.

my $cleanup
= sub
{
    my $node    = shift;
    @$node      = ();

    return
};


########################################################################
# public interface
########################################################################

# entry with a link-to-empty-next.
#
# the nested arrayref is the first
# node on the list. this is required
# for unshift to add the first node
# after the head.

sub construct
{
    my $proto   = shift;

    my $listh   = bless \[], blessed $proto || $proto;

    $rootz{ refaddr $listh } = [ $$listh ];

    $listh
}

sub initialize
{
    my $listh   = shift;

    # data for the list is on the stack.
    # otherwise the caller gets back an
    # empty list.

    if( @_ )
    {
        # no telling if somone overloaded new and
        # moved the node. only fix is to re-set the
        # thing to the head before adding the data.
        #
        # or... they know enough to leave it alone
        # if they want to so this should just take
        # the location as-is.

        my $node    = $listh->head_node;

        ( $node ) = @$node = ( [], $_ )
        for @_;
    }
    else
    {
        $listh->head;
    }

    return
}

sub new
{
    my $listh   = &construct;

    $listh->initialize( @_ );

    $listh
}

sub clone
{
    # recycle the head node

    my $listh   = shift;

    my $clone   = bless \[ $$listh ], blessed $listh || $listh;

    $rootz{ refaddr $clone } = $rootz{ refaddr $listh };

    $clone
}

sub DESTROY
{
    my $head    = delete $rootz{ refaddr shift };

    $#$head     = -1;

    return
}

# if $rootz{ $key } isn't removed then the
# node = node->next approach works just fine.
# so, truncate can use the faster aproach.

sub truncate
{
    my $listh   = shift;

    my $node    = $$listh;

    my $next    = splice @$node, 0, 1, [];

    $cleanup->( $next );

    $listh
}

sub replace
{
    my $listh   = shift;

    $listh->head->truncate;

    $listh->initialize( @_ );

    $listh
}

########################################################################
# basic information: the current node referenced by the list handler
#
# calling node without an argument returns the current one, with one
# sets the node. this allows for tell/reset-style stacking of node
# positions.

sub node
{
    my $listh   = shift;

    @_
    ? $$listh   = shift
    : $$listh
}

########################################################################
# hide extra data in the head node after the first-node ref.
#
# splice with $#$head works since 1 .. end == length - 1 == offset.

sub set_meta
{
    my $listh   = shift;

    my $root    = $listh->root;

    splice @$root, 1, $#$root, @_;

    $listh
}

sub add_meta
{
    my $listh   = shift;

    my $root    = $listh->root;

    push @$root, @_;

    $listh
}

sub get_meta
{
    my $root    = $_[0]->root;

    wantarray
    ?   @{ $root }[ 1 .. $#$root ]
    : [ @{ $root }[ 1 .. $#$root ] ]
}

########################################################################
# node/list status

sub has_nodes
{
    # i.e., is the list populated?

    my $root    = $_[0]->root;

    !! @{ $root->[0] }
}

sub has_next
{
    # i.e., while( $node->has_next ){ ... }

    my $listh   = shift;

    scalar @{ $$listh->[0] }
}

sub is_empty
{
    # Q: does the current node have data?
    # A: it will if there is more than one element.

    my $listh   = shift;

    ! @{ $$listh }
}

sub node_data
{
    my $listh   = shift;
    my $node    = $$listh;

    # return the existing data, sans the next ref.

    wantarray
    ?   @{ $node }[ 1 .. $#$node ]
    : [ @{ $node }[ 1 .. $#$node ] ]
}

sub next_data
{
    my $listh   = shift;
    my $node    = $$listh;
    my $next    = $node->[0];

    my @valz    = @{ $next }[ 1 .. $#$next ];

    wantarray
    ?  @valz
    : \@valz
}

sub set_data
{
    my $listh   = shift;
    my $node    = $$listh;

    # any data to replace the current data is
    # left on the stack.

    # return the existing data.

    if( defined wantarray )
    {
        my @valz    = @{ $node }[ 1 .. $#$node ];

        @_ and splice @$node, 1, $#$node, @_;

        wantarray
        ?  @valz
        : \@valz
    }
    else
    {
        splice @$node, 1, $#$node, @_;

        return
    }
}

sub clear_data
{
    my $listh   = shift;
    my $node    = $$listh;

    splice @$node, 1;

    $listh
}

sub list_data
{
    my $listh   = shift;
    my $node    = $$listh;

    my @return  = ();

    while( @$node )
    {
        my ( $node, @data ) = @$node;
        push @return, \@data;
    }

    wantarray
    ?  @return
    : \@return
}

########################################################################
# access the list head.
#
# root is mainly useful for testing,
# head_node for externally walking the
# list (i.e., when OO calls are too expensive).
#
# new_head is surgery: replace the head node.
# leaves most sanity checks in the
# caller's hands.
#
# mainly useful for cross-linked lists.

sub new_root
{
    my $listh   = shift;

    # called without arguments is an error: no reason to
    # do it and it can cause real pain if not caught.

    my $root    = shift
    or confess "Bogus new_root: false root (use truncate instead?)";

    'ARRAY' eq reftype $root
    or confess "Bogus new_root: non-arrayref root";

    $root->[0]  ||= [];

    $$listh     = $root->[0];

    my $key     = refaddr $listh;

    $cleanup->( delete $rootz{ $key } );

    $rootz{ $key }  = $root;

    $listh
}

sub new_head
{
    my ( $listh, $head ) = @_;

    my $root    = $listh->root_node;

    $head       = splice @$root, 0, 1, $head;

    $cleanup->( $head );

    $listh->head
}

sub root_node
{
    scalar $rootz{ refaddr $_[0] }
}

sub head_node
{
    my $listh   = shift;

    my $root    = $listh->root_node;

    $root->[0]
}

sub root
{
    my $listh   = shift;
    my $root    = $listh->root_node;
    $$listh     = $root;

    $listh
}

sub head
{
    my $listh   = shift;
    my $head    = $listh->head_node;
    $$listh     = $head;

    $listh
}

########################################################################
# walk the list.

sub next
{
    my $listh   = shift;
    my $node    = $$listh;

    my $count   = @_ ? shift : 1;

    looks_like_number $count
    or croak "Bogus move: '$count' is not a number";

    for( 1 .. $count )
    {
        @$node or last;

        $node = $node->[0];
    }

    $$listh     = $node;

    $listh
}

# this returns false for the scalar
# case, where an empty node returns
# an empty arrayref.
#
# Q: Better to reset or stall and EOL?
# A: Better leaving the reset to the caller, who knows
#    what to expect in that case.

sub each
{
    my $listh   = shift;
    my $node    = $$listh;

    $node
    or return;

    ( $$listh, my @valz )  = @$node;

    wantarray
    ?  @valz
    : \@valz
}

########################################################################
# keep this section at the end to avoid uses with CORE::* functions.
########################################################################
# modify the list
#
# add uses a relative position (e.g., for insertion sort), others
# use the head (or last) node.

sub add
{
    my $listh   = shift;
    my $node    = $$listh;

    # insert after the current node.

    $node->[0]  = [ $node->[0], @_ ];

    $listh
}

# shift and cut do the same basic thing, question
# is whether it's done mid-list or at the head.
# pop could work this way if it weren't so bloody
# expensive to find/maintain the end of a list.
#
# note that shift has one bit of extra work in that
# it has to replace $$listh when it currently references
# the first node.

sub cut
{
    # no need to modify $$listh here since the
    # node after the current one is always removed.

    my $listh   = shift;
    my $node    = $$listh;

    # nothing to cut if we are at the end-of-list.
    # or the node prior to it.

    @{ $node->[0] }
    or return;

    if( defined wantarray )
    {
        ( $node->[0], my @valz ) = @{ $node->[0] };

        wantarray
        ?  @valz
        : \@valz
    }
    else
    {
        # just discard the data if the
        # user doesn't want it.

        $node->[0] = $node->[0][0];
    }
}

########################################################################
# put these last to avoid having to use CORE::*
# everywhere else.

sub splice
{
    my $listh   = shift;
    my $count   = shift || 0;

    looks_like_number $count
    or croak "Bogus splice: non-numeric count '$count'";

    $count < 0
    and croak "Bogus splice: negative count '$count'";

    # short circut if there is nothing to do.

    $count > 0 || @_ or return;

    my $node    = $$listh
    or confess "Bogus splice: empty list handler";

    my $dead    = '';

    if( $count > 0 )
    {
        my $tail    = $node;

        for( 1 .. $count )
        {
            @$tail or last;

            $tail   = $tail->[0];
        }

        # this is the start of the chain that gets removed.
        # keep it alive for a few steps to see if the caller
        # wants it back or we should clean it up.
        #
        # after that, splice the node out of the list.

        $dead       = $node->[0];
        $node->[0]  = delete $tail->[0];
        $tail->[0]  = [];
    }

    # at this point $dead is either false or
    # a runt linked list lacking its terminating
    # node.
    #
    # insert anything on the stack after the
    # current node.

    for( @_ )
    {
       $node    = $node->[0] = [ $node->[0], $_ ];
    }

    # nothing to return or clean up if there
    # wasn't anything removed.

    $dead or return;

    # if the caller wants anything back then
    # clean up the dead chain and hand it back.
    #
    # alternative: array of data?

    if( defined wantarray )
    {
        # hand back a linked list with $dead as the head node.

        my $new     = $listh->new;

        my $head    = $$new;

        @$head      = @$dead;

        return $new
    }
    else
    {
        $cleanup->( $dead );

        return
    }
}

########################################################################
# aside: push can be very expensive.
# but, then, so is maintaining a separate
# node-before-the-tail entry.
#
# successive pushes are quite fast, due to
# leaving $$listh on the newly added node,
# which leaves the while loop running only
# once per push.

sub push
{
    my $listh   = shift;
    my $node    = $$listh;

    $node       = $node->[0]
    while @$node;

    # at this point we're at the list tail: the
    # empty placeholder arrayref. populate it in
    # place with a new tail.

    @$node      = ( [], @_ );

    $$listh     = $node;

    $listh
}

sub unshift
{
    my $root    = $_[0]->root_node;

    $root->[0]  = [ $root->[0], @_ ];

    $_[0]
}

sub shift
{
    my $listh   = shift;
    my $root    = $listh->root_node;

    # need to replace $listh contents if it
    # referrs to the head we are removing!

    $$listh     = ''
    if $$listh == $root->[0];

    if( defined wantarray )
    {
        my @valz    = @{ $root->[0] };

        $root->[0]  = shift @valz;

        $$listh     ||= $root->[0];

        wantarray
        ? @valz
        : \@valz
    }
    else
    {
        # get this over with for cases where
        # the user doesn't want the data.

        $root->[0][0]
        and $root->[0]  = $root->[0][0];

        $$listh     ||= $root->[0];

        return
    }
}

# keep require happy

1

__END__