File Coverage

lib/Array/AsHash.pm

Criterion	Covered	Total	%
statement	261	266	98.1
branch	84	94	89.3
condition	16	16	100.0
subroutine	44	44	100.0
pod	31	31	100.0
total	436	451	96.6

package Array::AsHash;

use warnings;
use strict;
use Clone ();
use Scalar::Util qw(refaddr);

our $VERSION = '0.32';

my ( $_bool, $_to_string );

BEGIN {

    # these are defined in a BEGIN block because otherwise, overloading
    # doesn't get them in time.
    $_bool = sub {
        my $self = CORE::shift;
        return $self->acount;
    };

    $_to_string = sub {
        no warnings 'once';
        require Data::Dumper;
        local $Data::Dumper::Indent = 0;
        local $Data::Dumper::Terse  = 1;
        my $self   = CORE::shift;
        my $string = '';
        return $string unless $self;
        while ( my ( $k, $v ) = $self->each ) {

            foreach ( $k, $v ) {
                $_ = ref $_ ? Data::Dumper::Dumper($_) : $_;
            }
            $string .= "$k\n        $v\n";
        }
        return $string;
    };
}

use overload bool => $_bool, '""' => $_to_string, fallback => 1;

my $_actual_key = sub {
    my ( $self, $key ) = @_;
    if ( ref $key ) {
        my $new_key = $self->{curr_key_of}{ refaddr $key};
        return refaddr $key unless defined $new_key;
        $key = $new_key;
    }
    return $key;
};

# private because it doesn't match expectations.  The "index" of a
# non-existent key is one greater than the current list
my $_index = sub {
    my ( $self, $key ) = @_;
    my $index =
        $self->exists($key)
      ? $self->{index_of}{$key}
      : scalar @{ $self->{array_for} };    # automatically one greater
    return $index;
};

my $_croak = sub {
    my ( $proto, $message ) = @_;
    require Carp;
    Carp::croak($message);
};

my $_validate_kv_pairs = sub {
    my ( $self, $arg_for ) = @_;
    my $sub = $arg_for->{sub} || ( caller(1) )[3];

    if ( @{ $arg_for->{pairs} } % 2 ) {
        $self->$_croak("Arguments to $sub must be an even-sized list");
    }
};

sub new {
    my $class = shift;
    return $class->_initialize(@_);
}

sub _initialize {
    my ( $class, $arg_ref ) = @_;
    my $self = bless {} => $class;
    $self->{array_for} = [];
    return $self unless $arg_ref;
    my $array = $arg_ref->{array} || [];
    $self->{is_strict} = $arg_ref->{strict};
    $array = Clone::clone($array) if $arg_ref->{clone};

    unless ( 'ARRAY' eq ref $array ) {
        $class->$_croak('Argument to new() must be an array reference');
    }
    if ( @$array % 2 ) {
        $class->$_croak('Uneven number of keys in array');
    }

    $self->{array_for} = $array;
    foreach ( my $i = 0; $i < @$array; $i += 2 ) {
        my $key = $array->[$i];
        $self->{index_of}{$key} = $i;
        if ( ref $key ) {
            my $old_address = refaddr $arg_ref->{array}[$i];
            my $curr_key    = "$key";
            $self->{curr_key_of}{$old_address} = $curr_key;
        }
    }
    return $self;
}

sub get {
    my ( $self, @keys ) = @_;
    my @get;
    foreach my $key (@keys) {
        $key = $self->$_actual_key($key);
        next unless defined $key;
        my $exists = $self->exists($key);
        if ( $self->{is_strict} && !$exists ) {
            $self->$_croak("Cannot get non-existent key ($key)");
        }
        if ($exists) {
            CORE::push @get, $self->{array_for}[ $self->$_index($key) + 1 ];
        }
        elsif ( @keys > 1 ) {
            CORE::push @get, undef;
        }
        else {
            return;
        }
    }
    return wantarray ? @get
      : @keys > 1    ? \@get
      : $get[0];
}

my $_insert = sub {
    my ( $self, $key, $label, $index ) = splice @_, 0, 4;

    $self->$_validate_kv_pairs(
        { pairs => \@_, sub => "Array::AsHash::insert_$label" } );
    $key = $self->$_actual_key($key);

    unless ( $self->exists($key) ) {
        $self->$_croak("Cannot insert $label non-existent key ($key)");
    }
    foreach ( my $i = 0; $i < @_; $i += 2 ) {
        my $new_key = $_[$i];
        if ( $self->exists($new_key) ) {
            $self->$_croak("Cannot insert duplicate key ($new_key)");
        }
        $self->{index_of}{$new_key} = $index + $i;
    }

    my @tail = splice @{ $self->{array_for} }, $index;
    push @{ $self->{array_for} }, @_, @tail;
    my %seen = @_;
    foreach my $curr_key ( CORE::keys %{ $self->{index_of} } ) {
        if ( $self->{index_of}{$curr_key} >= $index
            && !exists $seen{$curr_key} )
        {
            $self->{index_of}{$curr_key} += @_;
        }
    }
    return $self;
};

sub strict {
    my $self = shift;
    return $self->{is_strict} unless @_;
    $self->{is_strict} = !!shift;
    return $self;
}

sub clone {
    my $self = CORE::shift;
    return ( ref $self )->new(
        {   array => scalar $self->get_array,
            clone => 1,
        }
    );
}

sub unshift {
    my ( $self, @kv_pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@kv_pairs } );
    foreach my $curr_key ( CORE::keys %{ $self->{index_of} } ) {
        $self->{index_of}{$curr_key} += @kv_pairs;
    }
    for ( my $i = 0; $i < @kv_pairs; $i += 2 ) {
        my ( $key, $value ) = @kv_pairs[ $i, $i + 1 ];
        if ( $self->exists($key) ) {
            $self->$_croak("Cannot unshift an existing key ($key)");
        }
        $self->{index_of}{$key} = $i;
    }
    unshift @{ $self->{array_for} }, @kv_pairs;
}

sub push {
    my ( $self, @kv_pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@kv_pairs } );
    my @array = $self->get_array;
    for ( my $i = 0; $i < @kv_pairs; $i += 2 ) {
        my ( $key, $value ) = @kv_pairs[ $i, $i + 1 ];
        if ( $self->exists($key) ) {
            $self->$_croak("Cannot push an existing key ($key)");
        }
        $self->{index_of}{$key} = @array + $i;
    }
    CORE::push @{ $self->{array_for} }, @kv_pairs;
}

sub pop {
    my $self = shift;
    return unless $self;
    my ( $key, $value ) = splice @{ $self->{array_for} }, -2;
    delete $self->{index_of}{$key};
    return wantarray ? ( $key, $value ) : [ $key, $value ];
}

sub shift {
    my $self = CORE::shift;
    return unless $self;
    foreach my $curr_key ( CORE::keys %{ $self->{index_of} } ) {
        $self->{index_of}{$curr_key} -= 2;
    }
    my ( $key, $value ) = splice @{ $self->{array_for} }, 0, 2;
    delete $self->{index_of}{$key};
    return wantarray ? ( $key, $value ) : [ $key, $value ];
}

sub hcount {
    my $self  = CORE::shift;
    my $count = $self->acount;
    return $count / 2;
}

sub acount {
    my $self  = CORE::shift;
    my @array = $self->get_array;
    return scalar @array;
}

sub hindex {
    my $self  = CORE::shift;
    my $index = $self->aindex(CORE::shift);
    return defined $index ? $index / 2 : ();
}

sub aindex {
    my $self = CORE::shift;
    my $key  = $self->$_actual_key(CORE::shift);
    return unless $self->exists($key);
    return $self->$_index($key);
}

sub keys {
    my $self  = CORE::shift;
    my @array = $self->get_array;
    my @keys;
    for ( my $i = 0; $i < @array; $i += 2 ) {
        CORE::push @keys, $array[$i];
    }
    return wantarray ? @keys : \@keys;
}

sub values {
    my $self  = CORE::shift;
    my @array = $self->get_array;
    my @values;
    for ( my $i = 1; $i < @array; $i += 2 ) {
        CORE::push @values, $array[$i];
    }
    return wantarray ? @values : \@values;
}

sub first {
    my $self  = CORE::shift;
    my $index = $self->{current_index_for};
    return defined $index && 2 == $index;
}

sub last {
    my $self  = CORE::shift;
    my $index = $self->{current_index_for};
    return defined $index && $self->acount == $index;
}

sub each {
    my $self = CORE::shift;

    my $each = sub {
        my $index = $self->{current_index_for} || 0;
        my @array = $self->get_array;
        if ( $index >= @array ) {
            $self->reset_each;
            return;
        }
        my ( $key, $value ) = @array[ $index, $index + 1 ];
        no warnings 'uninitialized';
        $self->{current_index_for} += 2;
        return ( $key, $value );
    };

    if (wantarray) {
        return $each->();
    }
    else {
        require Array::AsHash::Iterator;
        return Array::AsHash::Iterator->new(
            {   parent   => $self,
                iterator => $each,
            }
        );
    }
}
{
    no warnings 'once';
    *kv = \&each;
}

sub reset_each { CORE::shift->{current_index_for} = undef }

sub insert_before {
    my $self  = CORE::shift;
    my $key   = CORE::shift;
    my $index = $self->$_index($key);
    $self->$_insert( $key, 'before', $index, @_ );
}

sub insert_after {
    my $self  = CORE::shift;
    my $key   = CORE::shift;
    my $index = $self->$_index($key) + 2;
    $self->$_insert( $key, 'after', $index, @_ );
}

sub key_at {
    my $self = CORE::shift;
    my @keys;
    foreach my $index ( my @copy = @_ ) {    # prevent aliasing
        $index *= 2;
        CORE::push @keys => $self->{array_for}[$index];
    }
    return wantarray ? @keys
      : 1 == @_      ? $keys[0]
      : \@keys;
}

sub value_at {
    my $self = CORE::shift;
    my @values;
    foreach my $index ( my @copy = @_ ) {    # prevent aliasing
        $index = $index * 2 + 1;
        CORE::push @values => $self->{array_for}[$index];
    }
    return wantarray ? @values
      : 1 == @_      ? $values[0]
      : \@values;
}

sub delete {
    my $self     = CORE::shift;
    my $num_args = @_;
    my $key      = $self->$_actual_key(CORE::shift);
    my @value;

    if ( $self->exists($key) ) {
        my $index = $self->$_index($key);
        delete $self->{index_of}{$key};
        my ( undef, $value ) = splice @{ $self->{array_for} }, $index, 2;
        CORE::push @value, $value;
        foreach my $curr_key ( CORE::keys %{ $self->{index_of} } ) {
            if ( $self->{index_of}{$curr_key} >= $index ) {
                $self->{index_of}{$curr_key} -= 2;
            }
        }
    }
    elsif ( $self->{is_strict} ) {
        $self->$_croak("Cannot delete non-existent key ($key)");
    }
    if (@_) {
        CORE::push @value, $self->delete(@_);
    }
    return wantarray  ? @value
      : $num_args > 1 ? \@value
      : $value[0];
}

sub clear {
    my $self = CORE::shift;
    for my $spec (qw) {
        $self->{$spec} = undef;
    }
    @{ $self->{array_for} } = ();
    return $self;
}

sub exists {
    my ( $self, $key ) = @_;
    $key = $self->$_actual_key($key);
    return unless defined $key;

    return exists $self->{index_of}{$key};
}

sub rename {
    my ( $self, @pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@pairs } );

    foreach ( my $i = 0; $i < @pairs; $i += 2 ) {
        my ( $old, $new ) = @pairs[ $i, $i + 1 ];
        unless ( $self->exists($old) ) {
            $self->$_croak("Cannot rename non-existent key ($old)");
        }
        unless ( defined $new ) {
            $self->$_croak("Cannot rename ($old) to an undefined value");
        }
        if ( $self->exists($new) ) {
            $self->$_croak(
                "Cannot rename ($old) to an key which already exists ($new)"
            );
        }
        my $index = delete $self->{index_of}{$old};
        $self->{index_of}{$new} = $index;
        $self->{array_for}[$index] = $new;
    }
    return $self;
}

sub get_pairs {
    my ( $self, @keys ) = @_;

    my @pairs;
    foreach my $key (@keys) {
        if ( $self->exists($key) ) {
            CORE::push @pairs, $key, $self->get($key);
        }
        elsif ( $self->{is_strict} ) {
            $self->$_croak("Cannot get pair for non-existent key ($key)");
        }
    }
    return wantarray ? @pairs : \@pairs;
}

sub default {
    my ( $self, @pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@pairs } );

    for ( my $i = 0; $i < @pairs; $i += 2 ) {
        my ( $k, $v ) = @pairs[ $i, $i + 1 ];
        next if $self->exists($k);
        $self->put( $k, $v );
    }
    return $self;
}

sub add {
    my ( $self, @pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@pairs } );

    for ( my $i = 0; $i < @pairs; $i += 2 ) {
        my ( $key, $value ) = @pairs[ $i, $i + 1 ];
        $key = $self->$_actual_key($key);
        if ( $self->exists($key) ) {
            $self->$_croak("Cannot add existing key ($key)");
        }
        my $index = $self->$_index($key);
        $self->{index_of}{$key}          = $index;
        $self->{array_for}[$index]       = $key;
        $self->{array_for}[ $index + 1 ] = $value;
    }
    return $self;
}

sub put {
    my ( $self, @pairs ) = @_;
    $self->$_validate_kv_pairs( { pairs => \@pairs } );

    for ( my $i = 0; $i < @pairs; $i += 2 ) {
        my ( $key, $value ) = @pairs[ $i, $i + 1 ];
        $key = $self->$_actual_key($key);
        if ( !$self->exists($key) && $self->{is_strict} ) {
            $self->$_croak("Cannot put a non-existent key ($key)");
        }
        my $index = $self->$_index($key);
        $self->{index_of}{$key}          = $index;
        $self->{array_for}[$index]       = $key;
        $self->{array_for}[ $index + 1 ] = $value;
    }
    return $self;
}

sub get_array {
    my $self = CORE::shift;
    return wantarray
      ? @{ $self->{array_for} }
      : $self->{array_for};
}

1;
__END__