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