Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Support for "paths" to define exceptions in the rules. #4

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Support for "paths" to define exceptions in the rules. #4

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
99f7b0b
add support for 'paths' to define extra behaviors for specific parts
reneeb Sep 11, 2014
54c7622
add test for path support
reneeb Sep 11, 2014
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
91 changes: 77 additions & 14 deletions lib/Hash/Merge.pm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -32,7 +32,7 @@ $GLOBAL->{'behaviors'} = {
'HASH' => {
'SCALAR' => sub { $_[0] },
'ARRAY' => sub { $_[0] },
'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
'HASH' => sub { _merge_hashes( $_[0], $_[1], $_[2] ) },
},
},

Expand All @@ -50,7 +50,7 @@ $GLOBAL->{'behaviors'} = {
'HASH' => {
'SCALAR' => sub { $_[1] },
'ARRAY' => sub { [ values %{ $_[0] }, @{ $_[1] } ] },
'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
'HASH' => sub { _merge_hashes( $_[0], $_[1], $_[2] ) },
},
},

Expand All @@ -68,25 +68,25 @@ $GLOBAL->{'behaviors'} = {
'HASH' => {
'SCALAR' => sub { $_[0] },
'ARRAY' => sub { $_[0] },
'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
'HASH' => sub { _merge_hashes( $_[0], $_[1], $_[2] ) },
},
},

'RETAINMENT_PRECEDENT' => {
'SCALAR' => {
'SCALAR' => sub { [ $_[0], $_[1] ] },
'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1], $_[2] ) },
},
'ARRAY' => {
'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1], $_[2] ) },
},
'HASH' => {
'SCALAR' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
'ARRAY' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
'SCALAR' => sub { _merge_hashes( $_[0], _hashify( $_[1] ), $_[2] ) },
'ARRAY' => sub { _merge_hashes( $_[0], _hashify( $_[1] ), $_[2] ) },
'HASH' => sub { _merge_hashes( $_[0], $_[1], $_[2] ) },
},
},
};
Expand Down Expand Up @@ -170,10 +170,22 @@ sub get_clone_behavior {
return $self->{'clone'};
}

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

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

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

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

# 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
Expand All @@ -195,7 +207,7 @@ sub merge {
}

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

# This does a straight merge of hashes, delegating the merge-specific
Expand All @@ -204,24 +216,36 @@ sub merge {
sub _merge_hashes {
my $self = &_get_obj; # '&' + no args modifies current @_

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

$path = '' if !defined $path;

my %newhash;
foreach my $leftkey ( keys %$left ) {
if ( exists $right->{$leftkey} ) {
$newhash{$leftkey} = $self->merge( $left->{$leftkey}, $right->{$leftkey} );
my $new_path = $path . '/' . $leftkey;

if ( $self->get_path_behavior && exists $self->{'matrix'}{'paths'}{$new_path} ) {
$newhash{$leftkey} = $self->{'matrix'}{'paths'}{$new_path}->( $left->{$leftkey}, $right->{$leftkey}, $new_path );
}
elsif ( exists $right->{$leftkey} ) {
$newhash{$leftkey} = $self->merge( $left->{$leftkey}, $right->{$leftkey}, $new_path );
}
else {
$newhash{$leftkey} = $self->{clone} ? $self->_my_clone( $left->{$leftkey} ) : $left->{$leftkey};
}
}

foreach my $rightkey ( keys %$right ) {
if ( !exists $left->{$rightkey} ) {
my $new_path = $path . '/' . $rightkey;

if ( $self->get_path_behavior && !exists $left->{$rightkey} && exists $self->{'matrix'}{'paths'}{$new_path} ) {
$newhash{$rightkey} = $self->{'matrix'}{'paths'}{$new_path}->( $left, $right, $new_path );
}
elsif ( !exists $left->{$rightkey} ) {
$newhash{$rightkey} = $self->{clone} ? $self->_my_clone( $right->{$rightkey} ) : $right->{$rightkey};
}
}
Expand Down Expand Up @@ -466,6 +490,45 @@ whenever possible. By default, cloning is on (set to true).

Returns the current behavior for data cloning.

=item set_path_behavior( <scalar> )

Enable the support for paths. With paths, you can define exception rules
for merging. E.g. generally you want ARRAY <-> ARRAY merging to include
all elements from both sides, but for the arrays that belong to the key
"override" the right side should win:

$left = {
test => [1],
override => [1],
};

$right = {
test => [2],
override => [2],
};

$result = {
test => [1,2],
override => [2],
};

For that case you can define a path:

specify_behavior({
# all the definitions for SCALAR <-> ... and HASH <-> ...
ARRAY => {
ARRAY => sub { [ @{ $_[0] }, @{ $_[1] } ] },
# Definitions for ARRAY <-> SCALAR and ARRAY <-> HASH
},
paths => {
'/override' => sub { $_[1] },
},
});

=item get_path_behavior( )

Returns the current behavior for path support.

=item set_behavior( <scalar> )

Specify which built-in behavior for merging that is desired. The scalar
Expand Down
96 changes: 96 additions & 0 deletions t/04-paths.t
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,96 @@
#!/usr/bin/perl -w

use strict;
use Test::More tests=>27;
use Hash::Merge;

my %left = ( ss => 'left',
sa => 'left',
sh => 'left',
as => [ 'l1', 'l2' ],
aa => [ 'l1', 'l2' ],
ah => [ 'l1', 'l2' ],
hs => { left=>1 },
ha => { left=>1 },
hh => { left=>1 } );

my %right = ( ss => 'right',
as => 'right',
hs => 'right',
sa => [ 'r1', 'r2' ],
aa => [ 'r1', 'r2' ],
ha => [ 'r1', 'r2' ],
sh => { right=>1 },
ah => { right=>1 },
hh => { right=>1 } );

# Test left precedence
my $merge = Hash::Merge->new();
ok($merge->get_behavior() eq 'LEFT_PRECEDENT', 'no arg default is LEFT_PRECEDENT');


my %lp = %{$merge->merge( \%left, \%right )};

is_deeply( $lp{ss}, 'left', 'Left Precedent - Scalar on Scalar' );
is_deeply( $lp{sa}, 'left', 'Left Precedent - Scalar on Array' );
is_deeply( $lp{sh}, 'left', 'Left Precedent - Scalar on Hash' );
is_deeply( $lp{as}, [ 'l1', 'l2', 'right'], 'Left Precedent - Array on Scalar' );
is_deeply( $lp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Left Precedent - Array on Array' );
is_deeply( $lp{ah}, [ 'l1', 'l2', 1 ], 'Left Precedent - Array on Hash' );
is_deeply( $lp{hs}, { left=>1 }, 'Left Precedent - Hash on Scalar' );
is_deeply( $lp{ha}, { left=>1 }, 'Left Precedent - Hash on Array' );
is_deeply( $lp{hh}, { left=>1, right=>1 }, 'Left Precedent - Hash on Hash' );

ok($merge->set_behavior('RIGHT_PRECEDENT') eq 'LEFT_PRECEDENT', 'set_behavior() returns previous behavior');
ok($merge->get_behavior() eq 'RIGHT_PRECEDENT', 'set_behavior() actually sets the behavior)');

is $merge->get_path_behavior, undef;
is( $merge->set_path_behavior(1), undef );
is $merge->get_path_behavior, 1;

$left{oss} = 'left';
$right{oss} = 'right';

$left{ohh} = { left => 1 };
$right{ohh} = { right => 1 };

$left{mlhh} = { key => { left => 1 }, test => 1 };
$right{mlhh} = { key => { right =>1 }, another_key => 1 };

$merge->specify_behavior({
'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 { Hash::Merge::_merge_hashes( $_[0], $_[1], $_[2] ) },
},
paths => {
'/ss' => sub { $_[0] },
'/hh' => sub { my %hash = ( %{$_[0]}, %{$_[1]} ); $hash{$_} *= 2 for keys %hash; \%hash },
'/mlhh/key' => sub { $_[1] },
},
}, 'RIGHT_PRECEDENT');

my %rp = %{$merge->merge( \%left, \%right )};

is_deeply( $rp{ss}, 'left', 'Right Precedent - Scalar on Scalar - path' );
is_deeply( $rp{oss}, 'right', 'Right Precedent - Scalar on Scalar' );
is_deeply( $rp{sa}, [ 'left', 'r1', 'r2' ], 'Right Precedent - Scalar on Array' );
is_deeply( $rp{sh}, { right=>1 }, 'Right Precedent - Scalar on Hash' );
is_deeply( $rp{as}, 'right', 'Right Precedent - Array on Scalar' );
is_deeply( $rp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Right Precedent - Array on Array' );
is_deeply( $rp{ah}, { right=>1 }, 'Right Precedent - Array on Hash' );
is_deeply( $rp{hs}, 'right', 'Right Precedent - Hash on Scalar' );
is_deeply( $rp{ha}, [ 1, 'r1', 'r2' ], 'Right Precedent - Hash on Array' );
is_deeply( $rp{hh}, { left=>2, right=>2 }, 'Right Precedent - Hash on Hash - path' );
is_deeply( $rp{ohh}, { left=>1, right=>1 }, 'Right Precedent - Hash on Hash' );
is_deeply( $rp{mlhh}, { test=>1, another_key=>1, key => {right => 1} }, 'Right Precedent - Hash on Hash - multilevel path' );