File Coverage

blib/lib/Hash/Merge.pm

Criterion	Covered	Total	%
statement	158	175	90.2
branch	33	48	68.7
condition	11	22	50.0
subroutine	54	56	96.4
pod	7	8	87.5
total	263	309	85.1

package Hash::Merge;

use strict;
use warnings;

use Carp;
use Clone::Choose 0.008;
use Scalar::Util qw(blessed);

use base 'Exporter';
our $CONTEXT;

our $VERSION     = '0.300';
our @EXPORT_OK   = qw( merge _hashify _merge_hashes );
our %EXPORT_TAGS = ('custom' => [qw( _hashify _merge_hashes )]);

sub _init
{
    my $self = shift;

    defined $self->{behaviors}
      or $self->{behaviors} = {
        'LEFT_PRECEDENT' => {
            'SCALAR' => {
                'SCALAR' => sub { $_[0] },
                'ARRAY'  => sub { $_[0] },
                'HASH'   => sub { $_[0] },
            },
            'ARRAY' => {
                'SCALAR' => sub { [@{$_[0]}, $_[1]] },
                'ARRAY'  => sub { [@{$_[0]}, @{$_[1]}] },
                'HASH'   => sub { [@{$_[0]}, values %{$_[1]}] },
            },
            'HASH' => {
                'SCALAR' => sub { $_[0] },
                'ARRAY'  => sub { $_[0] },
                'HASH'   => sub { $self->_merge_hashes($_[0], $_[1]) },
            },
        },

        'RIGHT_PRECEDENT' => {
            'SCALAR' => {
                'SCALAR' => sub { $_[1] },
                'ARRAY'  => sub { [$_[0], @{$_[1]}] },
                'HASH'   => sub { $_[1] },
            },
            'ARRAY' => {
                'SCALAR' => sub { $_[1] },
                'ARRAY'  => sub { [@{$_[0]}, @{$_[1]}] },
                'HASH'   => sub { $_[1] },
            },
            'HASH' => {
                'SCALAR' => sub { $_[1] },
                'ARRAY'  => sub { [values %{$_[0]}, @{$_[1]}] },
                'HASH'   => sub { $self->_merge_hashes($_[0], $_[1]) },
            },
        },

        'STORAGE_PRECEDENT' => {
            'SCALAR' => {
                'SCALAR' => sub { $_[0] },
                'ARRAY'  => sub { [$_[0], @{$_[1]}] },
                'HASH'   => sub { $_[1] },
            },
            'ARRAY' => {
                'SCALAR' => sub { [@{$_[0]}, $_[1]] },
                'ARRAY'  => sub { [@{$_[0]}, @{$_[1]}] },
                'HASH'   => sub { $_[1] },
            },
            'HASH' => {
                'SCALAR' => sub { $_[0] },
                'ARRAY'  => sub { $_[0] },
                'HASH'   => sub { $self->_merge_hashes($_[0], $_[1]) },
            },
        },

        'RETAINMENT_PRECEDENT' => {
            'SCALAR' => {
                'SCALAR' => sub { [$_[0],                                      $_[1]] },
                'ARRAY'  => sub { [$_[0],                                      @{$_[1]}] },
                'HASH'   => sub { $self->_merge_hashes($self->_hashify($_[0]), $_[1]) },
            },
            'ARRAY' => {
                'SCALAR' => sub { [@{$_[0]},                                   $_[1]] },
                'ARRAY'  => sub { [@{$_[0]},                                   @{$_[1]}] },
                'HASH'   => sub { $self->_merge_hashes($self->_hashify($_[0]), $_[1]) },
            },
            'HASH' => {
                'SCALAR' => sub { $self->_merge_hashes($_[0], $self->_hashify($_[1])) },
                'ARRAY'  => sub { $self->_merge_hashes($_[0], $self->_hashify($_[1])) },
                'HASH'   => sub { $self->_merge_hashes($_[0], $_[1]) },
            },
        },
      };

    defined $self->{behavior} or $self->{behavior} = 'LEFT_PRECEDENT';

    croak "Behavior '$self->{behavior}' does not exist"
      if !exists $self->{behaviors}{$self->{behavior}};

    $self->{matrix} = $self->{behaviors}{$self->{behavior}};
    $self->{clone}  = 1;
}

sub new
{
    my ($pkg, $beh) = @_;
    $pkg = ref $pkg || $pkg;

    my $instance = bless {($beh ? (behavior => $beh) : ())}, $pkg;
    $instance->_init;

    return $instance;
}

sub set_behavior
{
    my $self  = &_get_obj;    # '&' + no args modifies current @_
    my $value = shift;

    my @behaviors = grep { /$value/i } keys %{$self->{'behaviors'}};
    if (scalar @behaviors == 0)
    {
        carp 'Behavior must be one of : ' . join(', ', keys %{$self->{'behaviors'}});
        return;
    }
    if (scalar @behaviors > 1)
    {
        croak 'Behavior must be unique in uppercase letters! You specified: ' . join ', ', @behaviors;
    }
    if (scalar @behaviors == 1)
    {
        $value = $behaviors[0];
    }

    my $oldvalue = $self->{'behavior'};
    $self->{'behavior'} = $value;
    $self->{'matrix'}   = $self->{'behaviors'}{$value};
    return $oldvalue;    # Use classic POSIX pattern for get/set: set returns previous value
}

sub get_behavior
{
    my $self = &_get_obj;    # '&' + no args modifies current @_
    return $self->{'behavior'};
}

sub add_behavior_spec
{
    my $self = &_get_obj;    # '&' + no args modifies current @_
    my ($matrix, $name) = @_;
    $name ||= 'user defined';
    if (exists $self->{'behaviors'}{$name})
    {
        carp "Behavior '$name' was already defined. Please take another name";
        return;
    }

    my @required = qw( SCALAR ARRAY HASH );

    foreach my $left (@required)
    {
        foreach my $right (@required)
        {
            if (!exists $matrix->{$left}->{$right})
            {
                carp "Behavior does not specify action for '$left' merging with '$right'";
                return;
            }
        }
    }

    $self->{'behavior'} = $name;
    $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
}

no strict "refs";
*specify_behavior = \&add_behavior_spec;
use strict;

sub get_behavior_spec
{
    my $self = &_get_obj;    # '&' + no args modifies current @_
    my ($name) = @_;
    $name ||= 'user defined';
    exists $self->{'behaviors'}{$name} and return $self->{'behaviors'}{$name};
  return:
}

sub set_clone_behavior
{
    my $self     = &_get_obj;          # '&' + no args modifies current @_
    my $oldvalue = $self->{'clone'};
    $self->{'clone'} = shift() ? 1 : 0;
    return $oldvalue;
}

sub get_clone_behavior
{
    my $self = &_get_obj;              # '&' + no args modifies current @_
    return $self->{'clone'};
}

sub merge
{
    my $self = &_get_obj;              # '&' + no args modifies current @_

    my ($left, $right) = @_;

    # For the general use of this module, we want to create duplicates
    # of all data that is merged.  This behavior can be shut off, but
    # can create havoc if references are used heavily.

    my $lefttype = ref($left);
    $lefttype = "SCALAR" unless defined $lefttype and defined $self->{'matrix'}->{$lefttype};

    my $righttype = ref($right);
    $righttype = "SCALAR" unless defined $righttype and defined $self->{'matrix'}->{$righttype};

    if ($self->{'clone'})
    {
        $left  = ref($left)  ? clone($left)  : $left;
        $right = ref($right) ? clone($right) : $right;
    }

    local $CONTEXT = $self;
    return $self->{'matrix'}->{$lefttype}{$righttype}->($left, $right);
}

# This does a straight merge of hashes, delegating the merge-specific
# work to 'merge'

sub _merge_hashes
{
    my $self = &_get_obj;    # '&' + no args modifies current @_

    my ($left, $right) = (shift, shift);
    if (ref $left ne 'HASH' || ref $right ne 'HASH')
    {
        carp 'Arguments for _merge_hashes must be hash references';
        return;
    }

    my %newhash;
    foreach my $key (keys %$left)
    {
        $newhash{$key} =
          exists $right->{$key}
          ? $self->merge($left->{$key}, $right->{$key})
          : $left->{$key};

    }

    foreach my $key (grep { !exists $left->{$_} } keys %$right)
    {
        $newhash{$key} = $right->{$key};
    }

    return \%newhash;
}

# Given a scalar or an array, creates a new hash where for each item in
# the passed scalar or array, the key is equal to the value.  Returns
# this new hash

sub _hashify
{
    my $self = &_get_obj;    # '&' + no args modifies current @_
    my $arg  = shift;
    if (ref $arg eq 'HASH')
    {
        carp 'Arguement for _hashify must not be a HASH ref';
        return;
    }

    my %newhash;
    if (ref $arg eq 'ARRAY')
    {
        foreach my $item (@$arg)
        {
            my $suffix = 2;
            my $name   = $item;
            while (exists $newhash{$name})
            {
                $name = $item . $suffix++;
            }
            $newhash{$name} = $item;
        }
    }
    else
    {
        $newhash{$arg} = $arg;
    }
    return \%newhash;
}

my $_global;

sub _get_obj
{
    if (my $type = ref $_[0])
    {
        return shift()
          if $type eq __PACKAGE__
          || (blessed $_[0] && $_[0]->isa(__PACKAGE__));
    }

    defined $CONTEXT and return $CONTEXT;
    defined $_global or $_global = Hash::Merge->new;
    return $_global;
}

1;

__END__