File Coverage

blib/lib/RapidApp/Util/Hash/Merge.pm
Criterion Covered Total %
statement 58 122 47.5
branch 24 54 44.4
condition 10 31 32.2
subroutine 11 19 57.8
pod 0 7 0.0
total 103 233 44.2


line stmt bran cond sub pod time code
1             package RapidApp::Util::Hash::Merge;
2              
3             # --- 2018-08-06 by HV ---
4             # This is a copy of Hash::Merge v2.00, since later versions do not behave as expected.
5             # This is a temporary measure. If at some point I (or someone) has time to figure out
6             # what to do to get the real Hash::Merge to play nicely, I'd be happy to unfactor this.
7             # In the meantime, its too important for this stuff to work properly.
8             # -- See https://github.com/vanstyn/RapidApp/issues/177 and possibly #155
9             # ---
10              
11 6     6   44 use strict;
  6         12  
  6         184  
12 6     6   32 use warnings;
  6         12  
  6         157  
13 6     6   30 use Carp;
  6         10  
  6         329  
14              
15 6     6   44 use base 'Exporter';
  6         12  
  6         668  
16 6     6   41 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $context);
  6         12  
  6         13601  
17              
18             my ( $GLOBAL, $clone );
19              
20             #$VERSION = '0.200';
21             @EXPORT_OK = qw( merge _hashify _merge_hashes );
22             %EXPORT_TAGS = ( 'custom' => [qw( _hashify _merge_hashes )] );
23              
24             $GLOBAL = {};
25             bless $GLOBAL, __PACKAGE__;
26             $context = $GLOBAL; # $context is a variable for merge and _merge_hashes. used by functions to respect calling context
27              
28             $GLOBAL->{'behaviors'} = {
29             'LEFT_PRECEDENT' => {
30             'SCALAR' => {
31             'SCALAR' => sub { $_[0] },
32             'ARRAY' => sub { $_[0] },
33             'HASH' => sub { $_[0] },
34             },
35             'ARRAY' => {
36             'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
37             'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
38             'HASH' => sub { [ @{ $_[0] }, values %{ $_[1] } ] },
39             },
40             'HASH' => {
41             'SCALAR' => sub { $_[0] },
42             'ARRAY' => sub { $_[0] },
43             'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
44             },
45             },
46              
47             'RIGHT_PRECEDENT' => {
48             'SCALAR' => {
49             'SCALAR' => sub { $_[1] },
50             'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
51             'HASH' => sub { $_[1] },
52             },
53             'ARRAY' => {
54             'SCALAR' => sub { $_[1] },
55             'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
56             'HASH' => sub { $_[1] },
57             },
58             'HASH' => {
59             'SCALAR' => sub { $_[1] },
60             'ARRAY' => sub { [ values %{ $_[0] }, @{ $_[1] } ] },
61             'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
62             },
63             },
64              
65             'STORAGE_PRECEDENT' => {
66             'SCALAR' => {
67             'SCALAR' => sub { $_[0] },
68             'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
69             'HASH' => sub { $_[1] },
70             },
71             'ARRAY' => {
72             'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
73             'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
74             'HASH' => sub { $_[1] },
75             },
76             'HASH' => {
77             'SCALAR' => sub { $_[0] },
78             'ARRAY' => sub { $_[0] },
79             'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
80             },
81             },
82              
83             'RETAINMENT_PRECEDENT' => {
84             'SCALAR' => {
85             'SCALAR' => sub { [ $_[0], $_[1] ] },
86             'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
87             'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
88             },
89             'ARRAY' => {
90             'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
91             'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
92             'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
93             },
94             'HASH' => {
95             'SCALAR' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
96             'ARRAY' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
97             'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
98             },
99             },
100             };
101              
102             $GLOBAL->{'behavior'} = 'LEFT_PRECEDENT';
103             $GLOBAL->{'matrix'} = $GLOBAL->{behaviors}{ $GLOBAL->{'behavior'} };
104             $GLOBAL->{'clone'} = 1;
105              
106             sub _get_obj {
107 90548 100   90548   180935 if ( my $type = ref $_[0] ) {
108 73389 100 66     161960 return shift() if $type eq __PACKAGE__ || eval { $_[0]->isa(__PACKAGE__) };
  29012         162376  
109             }
110              
111 46171         85445 return $context;
112             }
113              
114             sub new {
115 0     0 0 0 my $pkg = shift;
116 0   0     0 $pkg = ref $pkg || $pkg;
117 0   0     0 my $beh = shift || $context->{'behavior'};
118              
119 0 0       0 croak "Behavior '$beh' does not exist" if !exists $context->{'behaviors'}{$beh};
120              
121             return bless {
122             'behavior' => $beh,
123 0         0 'matrix' => $context->{'behaviors'}{$beh},
124             }, $pkg;
125             }
126              
127             sub set_behavior {
128 6     6 0 53 my $self = &_get_obj; # '&' + no args modifies current @_
129 6         27 my $value = uc(shift);
130 6 0 33     49 if ( !exists $self->{'behaviors'}{$value} and !exists $GLOBAL->{'behaviors'}{$value} ) {
131 0         0 carp 'Behavior must be one of : ' . join( ', ', keys %{ $self->{'behaviors'} }, keys %{ $GLOBAL->{'behaviors'}{$value} } );
  0         0  
  0         0  
132 0         0 return;
133             }
134 6         20 my $oldvalue = $self->{'behavior'};
135 6         18 $self->{'behavior'} = $value;
136 6   33     38 $self->{'matrix'} = $self->{'behaviors'}{$value} || $GLOBAL->{'behaviors'}{$value};
137 6         21 return $oldvalue; # Use classic POSIX pattern for get/set: set returns previous value
138             }
139              
140             sub get_behavior {
141 0     0 0 0 my $self = &_get_obj; # '&' + no args modifies current @_
142 0         0 return $self->{'behavior'};
143             }
144              
145             sub specify_behavior {
146 0     0 0 0 my $self = &_get_obj; # '&' + no args modifies current @_
147 0         0 my ( $matrix, $name ) = @_;
148 0   0     0 $name ||= 'user defined';
149 0 0       0 if ( exists $self->{'behaviors'}{$name} ) {
150 0         0 carp "Behavior '$name' was already defined. Please take another name";
151 0         0 return;
152             }
153              
154 0         0 my @required = qw( SCALAR ARRAY HASH );
155              
156 0         0 foreach my $left (@required) {
157 0         0 foreach my $right (@required) {
158 0 0       0 if ( !exists $matrix->{$left}->{$right} ) {
159 0         0 carp "Behavior does not specify action for '$left' merging with '$right'";
160 0         0 return;
161             }
162             }
163             }
164              
165 0         0 $self->{'behavior'} = $name;
166 0         0 $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
167             }
168              
169             sub set_clone_behavior {
170 0     0 0 0 my $self = &_get_obj; # '&' + no args modifies current @_
171 0         0 my $oldvalue = $self->{'clone'};
172 0 0       0 $self->{'clone'} = shift() ? 1 : 0;
173 0         0 return $oldvalue;
174             }
175              
176             sub get_clone_behavior {
177 0     0 0 0 my $self = &_get_obj; # '&' + no args modifies current @_
178 0         0 return $self->{'clone'};
179             }
180              
181             sub merge {
182 18644     18644 0 28623 my $self = &_get_obj; # '&' + no args modifies current @_
183              
184 18644         37506 my ( $left, $right ) = @_;
185              
186             # For the general use of this module, we want to create duplicates
187             # of all data that is merged. This behavior can be shut off, but
188             # can create havoc if references are used heavily.
189              
190 18644 100       40493 my $lefttype =
    100          
191             ref $left eq 'HASH' ? 'HASH'
192             : ref $left eq 'ARRAY' ? 'ARRAY'
193             : 'SCALAR';
194              
195 18644 100       36562 my $righttype =
    100          
196             ref $right eq 'HASH' ? 'HASH'
197             : ref $right eq 'ARRAY' ? 'ARRAY'
198             : 'SCALAR';
199              
200 18644 50       34893 if ( $self->{'clone'} ) {
201 18644         31459 $left = _my_clone( $left, 1 );
202 18644         35681 $right = _my_clone( $right, 1 );
203             }
204              
205 18644         32125 local $context = $self;
206 18644         43214 return $self->{'matrix'}->{$lefttype}{$righttype}->( $left, $right );
207             }
208              
209             # This does a straight merge of hashes, delegating the merge-specific
210             # work to 'merge'
211              
212             sub _merge_hashes {
213 5087     5087   8214 my $self = &_get_obj; # '&' + no args modifies current @_
214              
215 5087         10354 my ( $left, $right ) = ( shift, shift );
216 5087 50 33     19355 if ( ref $left ne 'HASH' || ref $right ne 'HASH' ) {
217 0         0 carp 'Arguments for _merge_hashes must be hash references';
218 0         0 return;
219             }
220              
221 5087         7813 my %newhash;
222 5087         15607 foreach my $leftkey ( keys %$left ) {
223 16155 100       29195 if ( exists $right->{$leftkey} ) {
224 14854         29090 $newhash{$leftkey} = $self->merge( $left->{$leftkey}, $right->{$leftkey} );
225             }
226             else {
227 1301 50       2879 $newhash{$leftkey} = $self->{clone} ? $self->_my_clone( $left->{$leftkey} ) : $left->{$leftkey};
228             }
229             }
230              
231 5087         17515 foreach my $rightkey ( keys %$right ) {
232 43076 100       81078 if ( !exists $left->{$rightkey} ) {
233 28222 50       59240 $newhash{$rightkey} = $self->{clone} ? $self->_my_clone( $right->{$rightkey} ) : $right->{$rightkey};
234             }
235             }
236              
237 5087         42921 return \%newhash;
238             }
239              
240             # Given a scalar or an array, creates a new hash where for each item in
241             # the passed scalar or array, the key is equal to the value. Returns
242             # this new hash
243              
244             sub _hashify {
245 0     0   0 my $self = &_get_obj; # '&' + no args modifies current @_
246 0         0 my $arg = shift;
247 0 0       0 if ( ref $arg eq 'HASH' ) {
248 0         0 carp 'Arguement for _hashify must not be a HASH ref';
249 0         0 return;
250             }
251              
252 0         0 my %newhash;
253 0 0       0 if ( ref $arg eq 'ARRAY' ) {
254 0         0 foreach my $item (@$arg) {
255 0         0 my $suffix = 2;
256 0         0 my $name = $item;
257 0         0 while ( exists $newhash{$name} ) {
258 0         0 $name = $item . $suffix++;
259             }
260 0         0 $newhash{$name} = $item;
261             }
262             }
263             else {
264 0         0 $newhash{$arg} = $arg;
265             }
266 0         0 return \%newhash;
267             }
268              
269             # This adds some checks to the clone process, to deal with problems that
270             # the current distro of ActiveState perl has (specifically, it uses 0.09
271             # of Clone, which does not support the cloning of scalars). This simply
272             # wraps around clone as to prevent a scalar from being cloned via a
273             # Clone 0.09 process. This might mean that CODEREFs and anything else
274             # not a HASH or ARRAY won't be cloned.
275              
276             # $clone is global, which should point to coderef
277              
278             sub _my_clone {
279 66811     66811   92164 my $self = &_get_obj; # '&' + no args modifies current @_
280 66811         118101 my ( $arg, $depth ) = @_;
281              
282 66811 100 66     192981 if ( $self->{clone} && !$clone ) {
283 4 50       8 if ( eval { require Clone; 1 } ) {
  4 0       31  
  4 0       14  
284             $clone = sub {
285 66811 0 50 66811   144757 if ( !( $Clone::VERSION || 0 ) > 0.09
      33        
      33        
286             && ref $_[0] ne 'HASH'
287             && ref $_[0] ne 'ARRAY' ) {
288 0         0 my $var = shift; # Forced clone
289 0         0 return $var;
290             }
291 66811         310091 Clone::clone( shift, $depth );
292 4         29 };
293             }
294 0         0 elsif ( eval { require Storable; 1 } ) {
  0         0  
295             $clone = sub {
296 0     0   0 my $var = shift; # Forced clone
297 0 0       0 return $var if !ref($var);
298 0         0 Storable::dclone($var);
299 0         0 };
300             }
301 0         0 elsif ( eval { require Clone::PP; 1 } ) {
  0         0  
302             $clone = sub {
303 0     0   0 my $var = shift; # Forced clone
304 0 0       0 return $var if !ref($var);
305 0         0 Clone::PP::clone( $var, $depth );
306 0         0 };
307             }
308             else {
309 0         0 croak "Can't load Clone, Storable, or Clone::PP for cloning purpose";
310             }
311             }
312              
313 66811 50       106663 if ( $self->{'clone'} ) {
314 66811         100134 return $clone->($arg);
315             }
316             else {
317 0           return $arg;
318             }
319             }
320              
321             1;
322              
323             __END__
324              
325             =head1 NAME
326              
327             RappidApp::Util::Hash::Merge - Merges arbitrarily deep hashes into a single hash
328              
329             =head1 SYNOPSIS
330              
331             use RappidApp::Util:Hash::Merge qw( merge );
332             my %a = (
333             'foo' => 1,
334             'bar' => [ qw( a b e ) ],
335             'querty' => { 'bob' => 'alice' },
336             );
337             my %b = (
338             'foo' => 2,
339             'bar' => [ qw(c d) ],
340             'querty' => { 'ted' => 'margeret' },
341             );
342              
343             my %c = %{ merge( \%a, \%b ) };
344              
345             RappidApp::Util:Hash::Merge::set_behavior( 'RIGHT_PRECEDENT' );
346              
347             # This is the same as above
348              
349             RappidApp::Util:Hash::Merge::specify_behavior(
350             {
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 { RappidApp::Util:Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
365             },
366             },
367             'My Behavior',
368             );
369            
370             # Also there is OO interface.
371            
372             my $merge = RappidApp::Util:Hash::Merge->new( 'LEFT_PRECEDENT' );
373             my %c = %{ $merge->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             =head1 DESCRIPTION
379              
380             This is a copy of L<Hash::Merge> at version 2.00.
381              
382             See https://metacpan.org/pod/release/REHSACK/Hash-Merge-0.200/lib/Hash/Merge.pm
383              
384             Please don't use this as it may be removed at any time.
385              
386             =head1 AUTHOR
387              
388             Original author Michael K. Neylon E<lt>mneylon-pm@masemware.comE<gt>
389              
390             Trivial modifications by Henry Van Styn for L<RapidApp>
391              
392             See https://github.com/vanstyn/RapidApp/issues/177 for why this copy was created.
393              
394             =head1 COPYRIGHT
395              
396             Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved.
397              
398             This library is free software. You can redistribute it and/or modify it
399             under the same terms as Perl itself.
400              
401             =cut