1package Hash::Merge; 2 3use strict; 4use warnings; 5 6use Carp; 7use Clone::Choose 0.008; 8use Scalar::Util qw(blessed weaken); 9 10use base 'Exporter'; 11our $CONTEXT; 12 13our $VERSION = '0.302'; 14our @EXPORT_OK = qw( merge _hashify _merge_hashes ); 15our %EXPORT_TAGS = ('custom' => [qw( _hashify _merge_hashes )]); 16 17sub _init 18{ 19 my $self = shift; 20 21 my $weak = $self; 22 weaken $weak; 23 24 defined $self->{behaviors} 25 or $self->{behaviors} = { 26 'LEFT_PRECEDENT' => { 27 'SCALAR' => { 28 'SCALAR' => sub { $_[0] }, 29 'ARRAY' => sub { $_[0] }, 30 'HASH' => sub { $_[0] }, 31 }, 32 'ARRAY' => { 33 'SCALAR' => sub { [@{$_[0]}, $_[1]] }, 34 'ARRAY' => sub { [@{$_[0]}, @{$_[1]}] }, 35 'HASH' => sub { [@{$_[0]}, values %{$_[1]}] }, 36 }, 37 'HASH' => { 38 'SCALAR' => sub { $_[0] }, 39 'ARRAY' => sub { $_[0] }, 40 'HASH' => sub { $weak->_merge_hashes($_[0], $_[1]) }, 41 }, 42 }, 43 44 'RIGHT_PRECEDENT' => { 45 'SCALAR' => { 46 'SCALAR' => sub { $_[1] }, 47 'ARRAY' => sub { [$_[0], @{$_[1]}] }, 48 'HASH' => sub { $_[1] }, 49 }, 50 'ARRAY' => { 51 'SCALAR' => sub { $_[1] }, 52 'ARRAY' => sub { [@{$_[0]}, @{$_[1]}] }, 53 'HASH' => sub { $_[1] }, 54 }, 55 'HASH' => { 56 'SCALAR' => sub { $_[1] }, 57 'ARRAY' => sub { [values %{$_[0]}, @{$_[1]}] }, 58 'HASH' => sub { $weak->_merge_hashes($_[0], $_[1]) }, 59 }, 60 }, 61 62 'STORAGE_PRECEDENT' => { 63 'SCALAR' => { 64 'SCALAR' => sub { $_[0] }, 65 'ARRAY' => sub { [$_[0], @{$_[1]}] }, 66 'HASH' => sub { $_[1] }, 67 }, 68 'ARRAY' => { 69 'SCALAR' => sub { [@{$_[0]}, $_[1]] }, 70 'ARRAY' => sub { [@{$_[0]}, @{$_[1]}] }, 71 'HASH' => sub { $_[1] }, 72 }, 73 'HASH' => { 74 'SCALAR' => sub { $_[0] }, 75 'ARRAY' => sub { $_[0] }, 76 'HASH' => sub { $weak->_merge_hashes($_[0], $_[1]) }, 77 }, 78 }, 79 80 'RETAINMENT_PRECEDENT' => { 81 'SCALAR' => { 82 'SCALAR' => sub { [$_[0], $_[1]] }, 83 'ARRAY' => sub { [$_[0], @{$_[1]}] }, 84 'HASH' => sub { $weak->_merge_hashes($weak->_hashify($_[0]), $_[1]) }, 85 }, 86 'ARRAY' => { 87 'SCALAR' => sub { [@{$_[0]}, $_[1]] }, 88 'ARRAY' => sub { [@{$_[0]}, @{$_[1]}] }, 89 'HASH' => sub { $weak->_merge_hashes($weak->_hashify($_[0]), $_[1]) }, 90 }, 91 'HASH' => { 92 'SCALAR' => sub { $weak->_merge_hashes($_[0], $weak->_hashify($_[1])) }, 93 'ARRAY' => sub { $weak->_merge_hashes($_[0], $weak->_hashify($_[1])) }, 94 'HASH' => sub { $weak->_merge_hashes($_[0], $_[1]) }, 95 }, 96 }, 97 }; 98 99 defined $self->{behavior} or $self->{behavior} = 'LEFT_PRECEDENT'; 100 101 croak "Behavior '$self->{behavior}' does not exist" 102 if !exists $self->{behaviors}{$self->{behavior}}; 103 104 $self->{matrix} = $self->{behaviors}{$self->{behavior}}; 105 $self->{clone} = 1; 106} 107 108sub new 109{ 110 my ($pkg, $beh) = @_; 111 $pkg = ref $pkg || $pkg; 112 113 my $instance = bless {($beh ? (behavior => $beh) : ())}, $pkg; 114 $instance->_init; 115 116 return $instance; 117} 118 119sub set_behavior 120{ 121 my $self = &_get_obj; # '&' + no args modifies current @_ 122 my $value = shift; 123 124 my @behaviors = grep { /^$value$/i } keys %{$self->{'behaviors'}}; 125 if (scalar @behaviors == 0) 126 { 127 carp 'Behavior must be one of : ' . join(', ', keys %{$self->{'behaviors'}}); 128 return; 129 } 130 if (scalar @behaviors > 1) 131 { 132 croak 'Behavior must be unique in uppercase letters! You specified: ' . join ', ', @behaviors; 133 } 134 if (scalar @behaviors == 1) 135 { 136 $value = $behaviors[0]; 137 } 138 139 my $oldvalue = $self->{'behavior'}; 140 $self->{'behavior'} = $value; 141 $self->{'matrix'} = $self->{'behaviors'}{$value}; 142 return $oldvalue; # Use classic POSIX pattern for get/set: set returns previous value 143} 144 145sub get_behavior 146{ 147 my $self = &_get_obj; # '&' + no args modifies current @_ 148 return $self->{'behavior'}; 149} 150 151sub add_behavior_spec 152{ 153 my $self = &_get_obj; # '&' + no args modifies current @_ 154 my ($matrix, $name) = @_; 155 $name ||= 'user defined'; 156 if (exists $self->{'behaviors'}{$name}) 157 { 158 carp "Behavior '$name' was already defined. Please take another name"; 159 return; 160 } 161 162 my @required = qw( SCALAR ARRAY HASH ); 163 164 foreach my $left (@required) 165 { 166 foreach my $right (@required) 167 { 168 if (!exists $matrix->{$left}->{$right}) 169 { 170 carp "Behavior does not specify action for '$left' merging with '$right'"; 171 return; 172 } 173 } 174 } 175 176 $self->{'behavior'} = $name; 177 $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix; 178} 179 180no strict "refs"; 181*specify_behavior = \&add_behavior_spec; 182use strict; 183 184sub get_behavior_spec 185{ 186 my $self = &_get_obj; # '&' + no args modifies current @_ 187 my ($name) = @_; 188 $name ||= 'user defined'; 189 exists $self->{'behaviors'}{$name} and return $self->{'behaviors'}{$name}; 190 return: 191} 192 193sub set_clone_behavior 194{ 195 my $self = &_get_obj; # '&' + no args modifies current @_ 196 my $oldvalue = $self->{'clone'}; 197 $self->{'clone'} = shift() ? 1 : 0; 198 return $oldvalue; 199} 200 201sub get_clone_behavior 202{ 203 my $self = &_get_obj; # '&' + no args modifies current @_ 204 return $self->{'clone'}; 205} 206 207sub merge 208{ 209 my $self = &_get_obj; # '&' + no args modifies current @_ 210 211 my ($left, $right) = @_; 212 213 # For the general use of this module, we want to create duplicates 214 # of all data that is merged. This behavior can be shut off, but 215 # can create havoc if references are used heavily. 216 217 my $lefttype = ref($left); 218 $lefttype = "SCALAR" unless defined $lefttype and defined $self->{'matrix'}->{$lefttype}; 219 220 my $righttype = ref($right); 221 $righttype = "SCALAR" unless defined $righttype and defined $self->{'matrix'}->{$righttype}; 222 223 if ($self->{'clone'}) 224 { 225 $left = ref($left) ? clone($left) : $left; 226 $right = ref($right) ? clone($right) : $right; 227 } 228 229 local $CONTEXT = $self; 230 return $self->{'matrix'}->{$lefttype}{$righttype}->($left, $right); 231} 232 233# This does a straight merge of hashes, delegating the merge-specific 234# work to 'merge' 235 236sub _merge_hashes 237{ 238 my $self = &_get_obj; # '&' + no args modifies current @_ 239 240 my ($left, $right) = (shift, shift); 241 if (ref $left ne 'HASH' || ref $right ne 'HASH') 242 { 243 carp 'Arguments for _merge_hashes must be hash references'; 244 return; 245 } 246 247 my %newhash; 248 foreach my $key (keys %$left) 249 { 250 $newhash{$key} = 251 exists $right->{$key} 252 ? $self->merge($left->{$key}, $right->{$key}) 253 : $left->{$key}; 254 255 } 256 257 foreach my $key (grep { !exists $left->{$_} } keys %$right) 258 { 259 $newhash{$key} = $right->{$key}; 260 } 261 262 return \%newhash; 263} 264 265# Given a scalar or an array, creates a new hash where for each item in 266# the passed scalar or array, the key is equal to the value. Returns 267# this new hash 268 269sub _hashify 270{ 271 my $self = &_get_obj; # '&' + no args modifies current @_ 272 my $arg = shift; 273 if (ref $arg eq 'HASH') 274 { 275 carp 'Arguement for _hashify must not be a HASH ref'; 276 return; 277 } 278 279 my %newhash; 280 if (ref $arg eq 'ARRAY') 281 { 282 foreach my $item (@$arg) 283 { 284 my $suffix = 2; 285 my $name = $item; 286 while (exists $newhash{$name}) 287 { 288 $name = $item . $suffix++; 289 } 290 $newhash{$name} = $item; 291 } 292 } 293 else 294 { 295 $newhash{$arg} = $arg; 296 } 297 return \%newhash; 298} 299 300my $_global; 301 302sub _get_obj 303{ 304 if (my $type = ref $_[0]) 305 { 306 return shift() 307 if $type eq __PACKAGE__ 308 || (blessed $_[0] && $_[0]->isa(__PACKAGE__)); 309 } 310 311 defined $CONTEXT and return $CONTEXT; 312 defined $_global or $_global = Hash::Merge->new; 313 return $_global; 314} 315 3161; 317 318__END__ 319 320=head1 NAME 321 322Hash::Merge - Merges arbitrarily deep hashes into a single hash 323 324=begin html 325 326<a href="https://travis-ci.org/perl5-utils/Hash-Merge"><img src="https://travis-ci.org/perl5-utils/Hash-Merge.svg?branch=master" alt="Travis CI"/></a> 327<a href='https://coveralls.io/github/perl5-utils/Hash-Merge?branch=master'><img src='https://coveralls.io/repos/github/perl5-utils/Hash-Merge/badge.svg?branch=master' alt='Coverage Status'/></a> 328 329=end html 330 331=head1 SYNOPSIS 332 333 my %a = ( 334 'foo' => 1, 335 'bar' => [qw( a b e )], 336 'querty' => { 'bob' => 'alice' }, 337 ); 338 my %b = ( 339 'foo' => 2, 340 'bar' => [qw(c d)], 341 'querty' => { 'ted' => 'margeret' }, 342 ); 343 344 my %c = %{ merge( \%a, \%b ) }; 345 346 Hash::Merge::set_behavior('RIGHT_PRECEDENT'); 347 348 # This is the same as above 349 350 Hash::Merge::add_behavior_spec( 351 { 'SCALAR' => { 352 'SCALAR' => sub { $_[1] }, 353 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] }, 354 'HASH' => sub { $_[1] }, 355 }, 356 'ARRAY' => { 357 'SCALAR' => sub { $_[1] }, 358 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] }, 359 'HASH' => sub { $_[1] }, 360 }, 361 'HASH' => { 362 'SCALAR' => sub { $_[1] }, 363 'ARRAY' => sub { [ values %{ $_[0] }, @{ $_[1] } ] }, 364 'HASH' => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) }, 365 }, 366 }, 367 'My Behavior', 368 ); 369 370 # Also there is OO interface. 371 372 my $merger = Hash::Merge->new('LEFT_PRECEDENT'); 373 my %c = %{ $merger->merge( \%a, \%b ) }; 374 375 # All behavioral changes (e.g. $merge->set_behavior(...)), called on an object remain specific to that object 376 # The legacy "Global Setting" behavior is respected only when new called as a non-OO function. 377 378 # re-use globally specified behavior 379 my $merger = Hash::Merge->new(); 380 $merger->add_behavior_spec(Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior"); 381 my %c = %{ $merger->merge( \%a, \%b ) }; 382 383 # re-use externally specified behavior 384 use Hash::Merge::Extra (); 385 my $merger = Hash::Merge->new(); 386 $merger->add_behavior_spec(Hash::Merge::Extra::L_REPLACE, "L_REPLACE"); 387 my %c = %{ $merger->merge( \%a, \%b ) }; 388 389 390=head1 DESCRIPTION 391 392Hash::Merge merges two arbitrarily deep hashes into a single hash. That 393is, at any level, it will add non-conflicting key-value pairs from one 394hash to the other, and follows a set of specific rules when there are key 395value conflicts (as outlined below). The hash is followed recursively, 396so that deeply nested hashes that are at the same level will be merged 397when the parent hashes are merged. B<Please note that self-referencing 398hashes, or recursive references, are not handled well by this method.> 399 400Values in hashes are considered to be either ARRAY references, 401HASH references, or otherwise are treated as SCALARs. By default, the 402data passed to the merge function will be cloned using the Clone module; 403however, if necessary, this behavior can be changed to use as many of 404the original values as possible. (See C<set_clone_behavior>). 405 406Because there are a number of possible ways that one may want to merge 407values when keys are conflicting, Hash::Merge provides several preset 408methods for your convenience, as well as a way to define you own. 409These are (currently): 410 411=over 412 413=item Left Precedence 414 415This is the default behavior. 416 417The values buried in the left hash will never 418be lost; any values that can be added from the right hash will be 419attempted. 420 421 my $merge = Hash::Merge->new(); 422 my $merge = Hash::Merge->new('LEFT_PRECEDENT'); 423 $merge->set_behavior('LEFT_PRECEDENT'); 424 Hash::Merge::set_behavior('LEFT_PRECEDENT'); 425 426=item Right Precedence 427 428Same as Left Precedence, but with the right 429hash values never being lost 430 431 my $merge = Hash::Merge->new('RIGHT_PRECEDENT'); 432 $merge->set_behavior('RIGHT_PRECEDENT'); 433 Hash::Merge::set_behavior('RIGHT_PRECEDENT'); 434 435=item Storage Precedence 436 437If conflicting keys have two different 438storage mediums, the 'bigger' medium will win; arrays are preferred over 439scalars, hashes over either. The other medium will try to be fitted in 440the other, but if this isn't possible, the data is dropped. 441 442 my $merge = Hash::Merge->new('STORAGE_PRECEDENT'); 443 $merge->set_behavior('STORAGE_PRECEDENT'); 444 Hash::Merge::set_behavior('STORAGE_PRECEDENT'); 445 446=item Retainment Precedence 447 448No data will be lost; scalars will be joined 449with arrays, and scalars and arrays will be 'hashified' to fit them into 450a hash. 451 452 my $merge = Hash::Merge->new('RETAINMENT_PRECEDENT'); 453 $merge->set_behavior('RETAINMENT_PRECEDENT'); 454 Hash::Merge::set_behavior('RETAINMENT_PRECEDENT'); 455 456=back 457 458Specific descriptions of how these work are detailed below. 459 460=over 461 462=item merge ( <hashref>, <hashref> ) 463 464Merges two hashes given the rules specified. Returns a reference to 465the new hash. 466 467=item _hashify( <scalar>|<arrayref> ) -- INTERNAL FUNCTION 468 469Returns a reference to a hash created from the scalar or array reference, 470where, for the scalar value, or each item in the array, there is a key 471and it's value equal to that specific value. Example, if you pass scalar 472'3', the hash will be { 3 => 3 }. 473 474=item _merge_hashes( <hashref>, <hashref> ) -- INTERNAL FUNCTION 475 476Actually does the key-by-key evaluation of two hashes and returns 477the new merged hash. Note that this recursively calls C<merge>. 478 479=item set_clone_behavior( <scalar> ) 480 481Sets how the data cloning is handled by Hash::Merge. If this is true, 482then data will be cloned; if false, then original data will be used 483whenever possible. By default, cloning is on (set to true). 484 485=item get_clone_behavior( ) 486 487Returns the current behavior for data cloning. 488 489=item set_behavior( <scalar> ) 490 491Specify which built-in behavior for merging that is desired. The scalar 492must be one of those given below. 493 494=item get_behavior( ) 495 496Returns the behavior that is currently in use by Hash::Merge. 497 498=item specify_behavior( <hashref>, [<name>] ) [deprecated] 499 500Alias for C<add_behavior_spec>. 501 502=item add_behavior_spec( <hashref>, [<name>] ) 503 504Add a custom merge behavior spec for Hash::Merge. This must be a hashref 505defined with (at least) 3 keys, SCALAR, ARRAY, and HASH; each of those 506keys must have another hashref with (at least) the same 3 keys defined. 507Furthermore, the values in those hashes must be coderefs. These will be 508called with two arguments, the left and right values for the merge. 509Your coderef should return either a scalar or an array or hash reference 510as per your planned behavior. If necessary, use the functions 511_hashify and _merge_hashes as helper functions for these. For example, 512if you want to add the left SCALAR to the right ARRAY, you can have your 513behavior specification include: 514 515 %spec = ( ...SCALAR => { ARRAY => sub { [ $_[0], @$_[1] ] }, ... } } ); 516 517Note that you can import _hashify and _merge_hashes into your program's 518namespace with the 'custom' tag. 519 520=item get_behavior_spec( [<name>] ) 521 522Return a previously defined merge behavior spec. If name ism't specified, 523the same default as add_behavior_spec is applied. 524 525If no such name is known referring to an behavior spec, nothing is returned. 526 527=back 528 529=head1 BUILT-IN BEHAVIORS 530 531Here is the specifics on how the current internal behaviors are called, 532and what each does. Assume that the left value is given as $a, and 533the right as $b (these are either scalars or appropriate references) 534 535 LEFT TYPE RIGHT TYPE LEFT_PRECEDENT RIGHT_PRECEDENT 536 SCALAR SCALAR $a $b 537 SCALAR ARRAY $a ( $a, @$b ) 538 SCALAR HASH $a %$b 539 ARRAY SCALAR ( @$a, $b ) $b 540 ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b ) 541 ARRAY HASH ( @$a, values %$b ) %$b 542 HASH SCALAR %$a $b 543 HASH ARRAY %$a ( values %$a, @$b ) 544 HASH HASH merge( %$a, %$b ) merge( %$a, %$b ) 545 546 LEFT TYPE RIGHT TYPE STORAGE_PRECEDENT RETAINMENT_PRECEDENT 547 SCALAR SCALAR $a ( $a ,$b ) 548 SCALAR ARRAY ( $a, @$b ) ( $a, @$b ) 549 SCALAR HASH %$b merge( hashify( $a ), %$b ) 550 ARRAY SCALAR ( @$a, $b ) ( @$a, $b ) 551 ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b ) 552 ARRAY HASH %$b merge( hashify( @$a ), %$b ) 553 HASH SCALAR %$a merge( %$a, hashify( $b ) ) 554 HASH ARRAY %$a merge( %$a, hashify( @$b ) ) 555 HASH HASH merge( %$a, %$b ) merge( %$a, %$b ) 556 557(*) note that merge calls _merge_hashes, hashify calls _hashify. 558 559=head1 AUTHOR 560 561Michael K. Neylon E<lt>mneylon-pm@masemware.comE<gt>, 562Daniel Muey E<lt>dmuey@cpan.orgE<gt>, 563Jens Rehsack E<lt>rehsack@cpan.orgE<gt>, 564Stefan Hermes E<lt>hermes@cpan.orgE<gt> 565 566=head1 COPYRIGHT 567 568Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved. 569Copyright (c) 2013-2020 Jens Rehsack. All rights reserved. 570Copyright (c) 2017-2020 Stefan Hermes. All rights reserved. 571 572This library is free software. You can redistribute it and/or modify it 573under the same terms as Perl itself. 574 575=cut 576