File Coverage

blib/lib/Hash/Union.pm

Criterion	Covered	Total	%
statement	84	107	78.5
branch	55	100	55.0
condition	9	19	47.3
subroutine	9	9	100.0
pod	1	1	100.0
total	158	236	66.9

package Hash::Union;

use warnings FATAL => 'all';
use strict;

=head1 NAME

Hash::Union - smart hashes merging

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS

  use Hash::Union 'union';
  use Data::Dumper;                # for debug only

  my $config_base = {              # default application config
      'database' => 'production',  # production database
      'html_dirs' => [             # search paths for html documents
          '/docs/html/main',
          '/docs/html/default'
      ],
      'text_dirs' => [             # search paths fo text documents
          '/docs/text/main',
          '/docs/text/default'
      ]
  };

  my $config_local = {             # locally customized config
      'database' => 'stageing',    # devel database
      'prepend: html_dirs' => [    # local html pages preferred
          '/local/html/main',
          '/local/html/default'
      ],
      'append: text_dirs' => [     # fallback for nonexistent text
          '/local/text/main',
          '/local/text/default'
      ]
  };

  # now merge default with local
  my $config = union( [ $config_base, $config_local ] );

  print Dumper $config;

  ========

  $VAR1 = {
      'database' => 'stageing',
      'html_dirs' => [
          '/local/html/main',
          '/local/html/default',
          '/docs/html/main',
          '/docs/html/default'
      ],
      'text_dirs' => [
          '/docs/text/main',
          '/docs/text/default',
          '/local/text/main',
          '/local/text/default'
      ]
  };

=cut

use base qw'Exporter';
use vars qw'@EXPORT_OK';


=head1 EXPORT_OK

=head2 union( \@hash_references, %options );

Supported options:

=over

=item * reverse

Merge all hash references in reverse order.

=item * simple

Don't apply complex merging logic (ignore keys special meaning).

=back

=cut

@EXPORT_OK = qw'&union';

use Carp qw'croak';
use Storable qw'dclone';

use constant {
	OP_SET     => 0,
	OP_SETIF   => 1,
	OP_PREPEND => 2,
	OP_APPEND  => 3,
};


sub union {
	my ($hashes,%opts) = @_;

	croak "error: arrayref required" unless ref $hashes eq 'ARRAY';

	# never modify source hashes keys nor values
	$hashes = dclone $hashes;

	# exotic option
	@$hashes = reverse @$hashes if $opts{reverse};

	my $left = shift @$hashes;
	croak "error: hashref required" unless ref $left eq 'HASH' || !defined $left;

	while (@$hashes) {
		my $right = shift @$hashes;
		croak "error: hashref required" unless ref $right eq 'HASH' || !defined $right;
		$left = _union($left,$right,%opts);
	}
	return $left;
}

# internal routine
sub _union {
	my ($l,$r,%opts) = @_;

	# undef handling
	$l ||= {};
	$r ||= {};

	# normalize left keys
	unless ($opts{simple}) {
		for (keys %$l) {
			if (/^(?:\?=|ifnone:)\s*(.*)/) {            # '?= key', 'ifnone: key'
				croak "left '$_' violates with '$1'" if exists $l->{$1};
				$l->{$1} = delete $l->{$_};
			} elsif (/^(?:\+=|prepend:)\s*(.*)/) {      # '+= key', prepend: key'
				croak "left '$_' violates with '$1'" if exists $l->{$1};
				$l->{$1} = delete $l->{$_};
			} elsif (/^(?:=\+|append:)\s*(.*)/) {       # '=+ key', 'append: key'
				croak "left '$_' violates with '$1'" if exists $l->{$1};
				$l->{$1} = delete $l->{$_};
			} elsif (/^(?:=|set:)\s*(.*)/) {            # '= key', 'set: key'
				croak "left '$_' violates with '$1'" if exists $l->{$1};
				$l->{$1} = delete $l->{$_};
			}
		}
	}

	# now right...
	for my $k (keys %$r) {
		my ($lk, $op) = ($k, OP_SET);

		unless ($opts{simple}) {
			if ($k=~/^(?:\?=|ifnone:)\s*(.*)/) {        # '?= key', 'ifnone: key'
				croak "right '$_' violates with '$1'" if exists $r->{$1};
				($lk, $op) = ($1, OP_SETIF);
			} elsif ($k=~/^(?:\+=|prepend:)\s*(.*)/) {  # '+= key', 'prepend: key'
				croak "right '$_' violates with '$1'" if exists $r->{$1};
				($lk, $op) = ($1, OP_PREPEND);
			} elsif ($k=~/^(?:=\+|append:)\s*(.*)/) {   # '=+ key', 'append: key'
				croak "right '$_' violates with '$1'" if exists $r->{$1};
				($lk, $op) = ($1, OP_APPEND);
			} elsif ($k=~/^(?:=|set:)\s*(.*)/) {        # '= key', 'set: key'
				croak "right '$_' violates with '$1'" if exists $r->{$1};
				($lk, $op) = ($1, OP_SET);
			}
		}

		# undefs cases
		next unless defined $r->{$k};
		unless (defined $l->{$lk}) {
			$l->{$lk} = $r->{$k};
			next;
		}

		# res vs !ref
		croak "left '$lk' is ref, right '$k' isn't" if ref $l->{$lk} && !ref $r->{$k};
		croak "left '$lk' isn't ref, right '$k' is" if !ref $l->{$lk} && ref $r->{$k};

		# scalars
		unless (ref $l->{$lk}) {
			if ($op==OP_SET) {
				$l->{$lk} = $r->{$k};
			} elsif ($op==OP_SETIF) {
				$l->{$lk} ||= $r->{$k};
			} elsif ($op==OP_PREPEND) {
				$l->{$lk} = $r->{$k}.$l->{$lk};
			} elsif ($op==OP_APPEND) {
				$l->{$lk} .= $r->{$k};
			}
			next;
		}

		# incompatible kind of refs
		croak "type of left '$lk' incompatible with type of right '$k'" if ref $l->{$lk} ne ref $r->{$k};

		# scalars
		if (ref $l->{$lk} eq 'SCALAR') {
			if ($op==OP_SET) {
				$l->{$lk} = $r->{$k};
			} elsif ($op==OP_SETIF) {
				$l->{$lk} = $r->{$k} unless ${$l->{$lk}};
			} elsif ($op==OP_PREPEND) {
				${$l->{$lk}} = ${$r->{$k}}.${$l->{$lk}};
			} elsif ($op==OP_APPEND) {
				${$l->{$lk}} .= ${$r->{$k}};
			}
			next;
		}

		# arrays
		if (ref $l->{$lk} eq 'ARRAY') {
			if ($op==OP_SET) {
				$l->{$lk} = $r->{$k};
			} elsif ($op==OP_SETIF) {
				$l->{$lk} = $r->{$k} unless @{$l->{$lk}};
			} elsif ($op==OP_PREPEND) {
				unshift @{$l->{$lk}}, @{$r->{$k}};
			} elsif ($op==OP_APPEND) {
				push @{$l->{$lk}}, @{$r->{$k}};
			}
			next;
		}

		# hashes
		if (ref $l->{$lk} eq 'HASH') {
			if ($op==OP_SET) {
				$l->{$lk} = _union($l->{$lk}, $r->{$k},%opts);
			} elsif ($op==OP_SETIF) {
				$l->{$lk} = _union($l->{$lk}, $r->{$k}, %opts) unless %{$l->{$lk}};
			} elsif ($op==OP_PREPEND) {
				$l->{$lk} = _union($r->{$k}, $l->{$lk}, %opts);
			} elsif ($op==OP_APPEND) {
				$l->{$lk} = _union($l->{$lk}, $r->{$k}, %opts);
			}
			next;
		}

		# wtf?
		croak "unknown type of left '$lk'";
	}

	return $l;
}

1;

__END__