File Coverage

blib/lib/Hash/MultiValue.pm

Criterion	Covered	Total	%
statement	168	178	94.3
branch	24	26	92.3
condition	4	6	66.6
subroutine	29	31	93.5
pod	17	23	73.9
total	242	264	91.6

package Hash::MultiValue;

use strict;
no warnings 'void';
use 5.006_002;
our $VERSION = '0.16';

use Carp ();
use Scalar::Util qw(refaddr);

# there does not seem to be a relevant RT or perldelta entry for this
use constant _SPLICE_SAME_ARRAY_SEGFAULT => $] < '5.008007';

my %keys;
my %values;
my %registry;

BEGIN {
    require Config;
    my $needs_registry = ($^O eq 'Win32' || $Config::Config{useithreads});
    if ($needs_registry) {
        *CLONE = sub {
            foreach my $oldaddr (keys %registry) {
                my $this = refaddr $registry{$oldaddr};
                $keys{$this}   = delete $keys{$oldaddr};
                $values{$this} = delete $values{$oldaddr};
                Scalar::Util::weaken($registry{$this} = delete $registry{$oldaddr});
            }
        };
    }
    *NEEDS_REGISTRY = sub () { $needs_registry };
}

if (defined &UNIVERSAL::ref::import) {
    UNIVERSAL::ref->import;
}

sub ref { 'HASH' }

sub create {
    my $class = shift;
    my $self = bless {}, $class;
    my $this = refaddr $self;
    $keys{$this} = [];
    $values{$this} = [];
    Scalar::Util::weaken($registry{$this} = $self) if NEEDS_REGISTRY;
    $self;
}

sub new {
    my $class = shift;
    my $self = $class->create;
    unshift @_, $self;
    &{ $self->can('merge_flat') };
}

sub from_mixed {
    my $class = shift;
    my $self = $class->create;
    unshift @_, $self;
    &{ $self->can('merge_mixed') };
}

sub DESTROY {
    my $this = refaddr shift;
    delete $keys{$this};
    delete $values{$this};
    delete $registry{$this} if NEEDS_REGISTRY;
}

sub get {
    my($self, $key) = @_;
    $self->{$key};
}

sub get_all {
    my($self, $key) = @_;
    my $this = refaddr $self;
    my $k = $keys{$this};
    (@{$values{$this}}[grep { $key eq $k->[$_] } 0 .. $#$k]);
}

sub get_one {
    my ($self, $key) = @_;
    my @v = $self->get_all($key);
    return $v[0] if @v == 1;
    Carp::croak "Key not found: $key" if not @v;
    Carp::croak "Multiple values match: $key";
}

sub set {
    my $self = shift;
    my $key = shift;

    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};

    my @idx = grep { $key eq $k->[$_] } 0 .. $#$k;

    my $added = @_ - @idx;
    if ($added > 0) {
        my $start = $#$k + 1;
        push @$k, ($key) x $added;
        push @idx, $start .. $#$k;
    }
    elsif ($added < 0) {
        my ($start, @drop, @keep) = splice @idx, $added;
        for my $i ($start+1 .. $#$k) {
            if (@drop and $i == $drop[0]) {
                shift @drop;
                next;
            }
            push @keep, $i;
        }

        splice @$_, $start, 0+@$_, ( _SPLICE_SAME_ARRAY_SEGFAULT
            ? @{[ @$_[@keep] ]} # force different source array
            :     @$_[@keep]
        ) for $k, $v;
    }

    if (@_) {
        @$v[@idx] = @_;
        $self->{$key} = $_[-1];
    }
    else {
        delete $self->{$key};
    }

    $self;
}

sub add {
    my $self = shift;
    my $key = shift;
    $self->merge_mixed( $key => \@_ );
    $self;
}

sub merge_flat {
    my $self = shift;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};
    push @{ $_ & 1 ? $v : $k }, $_[$_] for 0 .. $#_;
    @{$self}{@$k} = @$v;
    $self;
}

sub merge_mixed {
    my $self = shift;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};

    my $hash;
    $hash = shift if @_ == 1;

    while ( my ($key, $value) = @_ ? splice @_, 0, 2 : each %$hash ) {
        if ( CORE::ref($value) eq 'ARRAY' ) {
            next if not @$value;
            push @$k, ($key) x @$value;
            push @$v, @$value;
        }
        else {
            push @$k, $key;
            push @$v, $value;
        }
        $self->{$key} = $v->[-1];
    }

    $self;
}

sub remove {
    my ($self, $key) = @_;
    $self->set($key);
    $self;
}

sub clear {
    my $self = shift;
    %$self = ();
    my $this = refaddr $self;
    $keys{$this} = [];
    $values{$this} = [];
    $self;
}

sub clone {
    my $self = shift;
    CORE::ref($self)->new($self->flatten);
}

sub keys {
    my $self = shift;
    return @{$keys{refaddr $self}};
}

sub values {
    my $self = shift;
    return @{$values{refaddr $self}};
}

sub flatten {
    my $self = shift;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};
    map { $k->[$_], $v->[$_] } 0 .. $#$k;
}

sub each {
    my ($self, $code) = @_;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};
    for (0 .. $#$k) {
        $code->($k->[$_], $v->[$_]);
    }
    return $self;
}

sub as_hashref {
    my $self = shift;
    my %hash = %$self;
    \%hash;
}

sub as_hashref_mixed {
    my $self = shift;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};

    my %hash;
    push @{$hash{$k->[$_]}}, $v->[$_] for 0 .. $#$k;
    for (CORE::values %hash) {
        $_ = $_->[0] if 1 == @$_;
    }

    \%hash;
}

*mixed = \&as_hashref_mixed;

sub as_hashref_multi {
    my $self = shift;
    my $this = refaddr $self;
    my $k = $keys{$this};
    my $v = $values{$this};

    my %hash;
    push @{$hash{$k->[$_]}}, $v->[$_] for 0 .. $#$k;

    \%hash;
}

*multi = \&as_hashref_multi;

sub STORABLE_freeze {
    my $self = shift;
    my $this = refaddr $self;
    return '', $keys{$this}, $values{$this};
}

sub STORABLE_thaw {
    my $self = shift;
    my ($is_cloning, $serialised, $k, $v) = @_;
    my $this = refaddr $self;
    $keys  {$this} = $k;
    $values{$this} = $v;
    @{$self}{@$k} = @$v;
    return $self;
}

1;
__END__