File Coverage

blib/lib/Blessed/Merge.pm

Criterion	Covered	Total	%
statement	80	80	100.0
branch	46	48	95.8
condition	23	26	88.4
subroutine	12	12	100.0
pod	2	2	100.0
total	163	168	97.0

package Blessed::Merge;

use 5.006;

our $VERSION = '0.11';
use strict;
use warnings;
use Scalar::Util qw/reftype/;
use Carp qw/croak/;
use Combine::Keys qw/combine_keys/;
use Tie::IxHash;

sub new {
	my ($pkg, $args) = (shift, reftype $_[0] || "" eq 'HASH' ? $_[0] : {@_});
	my $self = bless $args, $pkg;
	$self->{$_} = $self->{$_} // 1 foreach (qw/same blessed/);
	$self->{$_} = $self->{$_} // 0 foreach(qw/unique_array unique_hash/);
	$self->{itterator} = 1;
	return $self;
}

sub merge {
	my ($self, $base_bless, $new) = (shift, ref $_[0], shift);
	tie my %isa, 'Tie::IxHash';
	$isa{$base_bless} = $new;
	map {
		if ( $self->{same} ) {
			croak 'Attempting to merge two different *packages*' unless $base_bless eq ref $_;
		} else {
			my $r = ref $_;
			$isa{$r} = $_ unless $r =~ m/HASH|ARRAY|SCALAR/;
		}
		$new = $self->_merge($new, $_);
	} @_;
	for my $f (keys %isa) {
		my $check = $isa{$f} or next;
		$_ eq $f and next or $check->isa($_) and delete $isa{$_} for keys %isa;
	}
	return $self->{blessed} ? scalar keys %isa == 1 ? bless $new, $base_bless : do {
		my $class = sprintf "Blessed::Merge::__ANON__::%s", $self->{itterator}++;
		eval sprintf('package %s; our @ISA = qw/%s/; 1;', $class, join ' ', keys %isa);
		return bless $new, $class;
	} : $new;
}

sub _merge {
	my ($self, $new, $merger) = @_;
	return $new unless defined $merger;
	my $new_ref = reftype($new) || '';
	my $merger_ref = reftype($merger) || 'SCALAR';
	$merger_ref eq 'HASH' ? do {
		$new = {} if ( $new_ref ne 'HASH' );
		return {
			$self->{unique_hash}
				? $self->_unique_merge($merger_ref, $new, $merger)
				: map +( $_ => $self->_merge( $new->{$_}, $merger->{$_} ) ), combine_keys($new, $merger)
		};
	} : $merger_ref eq 'ARRAY' ? do {
		$new_ref eq 'ARRAY' ? do {
			my $length = sub {$_[0] < $_[1] ? $_[1] : $_[0]}->(scalar @{$new}, scalar @{$merger});
			[ $self->{unique_array}
				? $self->_unique_merge($merger_ref, $new, $merger, $length)
				: map { $self->_merge($new->[$_], $merger->[$_]) } 0 .. $length - 1
			];
		} : [ map { $self->_merge('', $_ ) } @{ $merger } ]; # destroy da references
	} : $merger;
}

sub _unique_merge {
	my ($s, $r, $n, $m, $l) = @_;
	($r eq 'ARRAY') && do {
		my (@z, %u, $x1, $x2);
		for (my $i = 0; $i < $l; $i++) {
			my $c = grep {
				my ($x) = reftype(\$_);
				$x eq 'SCALAR' ? !$_ || exists $u{$_} ? 1 : do { $u{$_} = 1; push @z, $_; } : 0;
			} ($n->[$i], $m->[$i]);
			do { ($x1, $x2) = (reftype($n->[$i]), reftype($m->[$i])); $c == 0 }
				? $x1 eq $x2
					? push @z, $s->_merge($n->[$i], $m->[$i])
					: push @z, $n->[$i], $m->[$i]
				: $x1
					? push @z, $n->[$i]
					: push @z, $m->[$i] if $c != 2;
		}
		return @z;
	};
	my %z = %{ $n };
	map {
		my $x = reftype($m->{$_}) || 'SCALAR';
		exists $z{$_} ? $x ne 'SCALAR' && $x eq reftype($z{$_})
			? do { $z{$_} = $s->_merge($z{$_}, $m->{$_}) } : '*\o/*' : do { $z{$_} = $m->{$_} }
	} keys %{ $m };
	return %z;
}

1;

__END__