add feature to change only a part of the merge behavior

lib/Hash/Merge.pm

@@ -158,6 +158,23 @@ sub specify_behavior {
     $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
 }
 
+sub specify_behavior_part {
+    my $self = &_get_obj;
+
+    my ( $matrix, $name ) = @_;
+    $name ||= $self->{'behavior'};
+
+    if ( !exists $self->{'behaviors'}{$name} and !exists $GLOBAL->{'behaviors'}{$name} ) {
+        carp 'Behavior must be one of : ' . join( ', ', keys %{ $self->{'behaviors'} }, keys %{ $GLOBAL->{'behaviors'}{$name} } );
+        return;
+    }
+
+    my $merger     = Hash::Merge->new;
+    $merger->set_behavior( 'RIGHT_PRECEDENT' );
+    my $new_matrix = $merger->merge( $self->{'behaviors'}{$name} || $GLOBAL->{'behaviors'}{$name}, $matrix );
+    $self->{'behaviors'}{$name} = $self->{'matrix'} = $new_matrix;
+}
+
 sub set_clone_behavior {
     my $self     = &_get_obj;          # '&' + no args modifies current @_
     my $oldvalue = $self->{'clone'};
@@ -493,6 +510,19 @@ behavior specification include:
 Note that you can import _hashify and _merge_hashes into your program's
 namespace with the 'custom' tag.
 
+=item specify_behavior_part( <hashref>, [<name>] )
+
+Specify only the parts of an existing behavior that should be changed.
+If you want to only change the merging behavior for SCALAR <-> SCALAR in
+the LEFT_PRECEDENT behavior, you can use
+
+  specify_behavior_part(
+    { SCALAR => { SCALAR => sub { $_[0] . '...' . $_[1] } } },
+    'LEFT_PRECEDENT'
+  );
+
+If the name is omitted, the current behavior is changed.
+
 =back
 
 =head1 BUILT-IN BEHAVIORS

t/03-behavior-part.t

@@ -0,0 +1,64 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests=>21;
+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');
+
+$merge->specify_behavior_part({
+    SCALAR => { SCALAR => sub { $_[0] . ' ' . $_[1] } },
+});
+
+my %lp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $lp{ss},	'left right',						'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' );
+
+$merge->specify_behavior_part({
+    SCALAR => { SCALAR => sub { $_[0] . ' # ' . $_[1] } },
+}, 'RIGHT_PRECEDENT' );
+
+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)');
+
+my %rp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $rp{ss},	'left # 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=>1, right=>1 },			'Right Precedent - Hash on Hash' );