/[cvs]/nfo/perl/libs/Hash/Merge.pm
ViewVC logotype

Contents of /nfo/perl/libs/Hash/Merge.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Feb 20 05:18:04 2003 UTC (21 years, 3 months ago) by joko
Branch: MAIN
+ initial commit, to-be-enhanced

1 #!/usr/bin/perl -w
2
3 package Hash::Merge;
4
5
6 # Id: Merge.pm,v 0.07 2002/02/19 00:21:27 mneylon Exp
7 # Revision: 0.07
8 # Author: mneylon
9 # Date: 2002/02/19 00:21:27
10 # Log: Merge.pm,v
11 # Revision 0.07 2002/02/19 00:21:27 mneylon
12 # Fixed problem with ActiveState Perl's Clone.pm implementation.
13 # Fixed typo in POD.
14 # Fixed formatting of code in general.
15 #
16 # Revision 0.06.01.2 2002/02/17 03:18:20 mneylon
17 # Fixed problem with ActiveState Perl's Clone.pm implementation.
18 # Fixed typo in POD.
19 # Fixed formatting of code in general.
20 #
21 # Revision 0.06.01.1 2002/02/17 02:48:54 mneylon
22 # Branched version.
23 #
24 # Revision 0.06 2001/11/10 03:30:34 mneylon
25 # Version 0.06 release (and more CVS fixes)
26 #
27 # Revision 0.05.02.2 2001/11/10 03:22:58 mneylon
28 # Updated documentation
29 #
30 # Revision 0.05.02.1 2001/11/08 00:14:48 mneylon
31 # Fixing CVS problems
32 #
33 # Revision 0.05.01.1 2001/11/06 03:26:56 mneylon
34 # Fixed some undefined variable problems for 5.005.
35 # Added cloning of data and set/get_clone_behavior functions
36 # Added associated testing of data cloning
37 # Fixed some problems with POD
38 #
39 # Revision 0.05 2001/11/02 02:15:54 mneylon
40 # Yet another fix to Test::More requirement (=> 0.33)
41 #
42 # Revision 0.04 2001/10/31 03:59:03 mneylon
43 # Forced Test::More requirement in makefile
44 # Fixed problems with pod documentation
45 #
46 # Revision 0.03 2001/10/28 23:36:12 mneylon
47 # CPAN Release with CVS fixes
48 #
49 # Revision 0.02 2001/10/28 23:05:03 mneylon
50 # CPAN release
51 #
52 # Revision 0.01.1.1 2001/10/23 03:01:34 mneylon
53 # Slight fixes
54 #
55 # Revision 0.01 2001/10/23 03:00:21 mneylon
56 # Initial Release to PerlMonks
57 #
58 #
59 #=============================================================================
60
61 use strict;
62 use Clone qw(clone);
63
64 BEGIN {
65 use Exporter ();
66 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK
67 %EXPORT_TAGS $CLONE_SUPPORT);
68 $VERSION = sprintf( "%d.%02d", q($Revision: 0.07 $) =~ /\s(\d+)\.(\d+)/ );
69 @ISA = qw(Exporter);
70 @EXPORT = qw();
71 @EXPORT_OK = qw( merge _hashify _merge_hashes );
72 %EXPORT_TAGS = ( custom => [ qw( _hashify _merge_hashes )] );
73 $CLONE_SUPPORT = ( $Clone::VERSION > 0.09 );
74
75 }
76
77 my %left_precedent = (
78 SCALAR => {
79 SCALAR => sub { $_[0] },
80 ARRAY => sub { $_[0] },
81 HASH => sub { $_[0] } },
82 ARRAY => {
83 SCALAR => sub { [ @{$_[0]}, $_[1] ] },
84 ARRAY => sub { [ @{$_[0]}, @{$_[1]} ] },
85 HASH => sub { [ @{$_[0]}, values %{$_[1]} ] } },
86 HASH => {
87 SCALAR => sub { $_[0] },
88 ARRAY => sub { $_[0] },
89 HASH => sub { _merge_hashes( $_[0], $_[1] ) } }
90 );
91
92 my %right_precedent = (
93 SCALAR => {
94 SCALAR => sub { $_[1] },
95 ARRAY => sub { [ $_[0], @{$_[1]} ] },
96 HASH => sub { $_[1] } },
97 ARRAY => {
98 SCALAR => sub { $_[1] },
99 ARRAY => sub { [ @{$_[0]}, @{$_[1]} ] },
100 HASH => sub { $_[1] } },
101 HASH => {
102 SCALAR => sub { $_[1] },
103 ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] },
104 HASH => sub { _merge_hashes( $_[0], $_[1] ) } }
105 );
106
107 my %storage_precedent = (
108 SCALAR => {
109 SCALAR => sub { $_[0] },
110 ARRAY => sub { [ $_[0], @{$_[1]} ] },
111 HASH => sub { $_[1] } },
112 ARRAY => {
113 SCALAR => sub { [ @{$_[0]}, $_[1] ] },
114 ARRAY => sub { [ @{$_[0]}, @{$_[1]} ] },
115 HASH => sub { $_[1] } },
116 HASH => {
117 SCALAR => sub { $_[0] },
118 ARRAY => sub { $_[0] },
119 HASH => sub { _merge_hashes( $_[0], $_[1] ) } }
120 );
121
122 my %retainment_precedent = (
123 SCALAR => {
124 SCALAR => sub { [ $_[0], $_[1] ] },
125 ARRAY => sub { [ $_[0], @{$_[1]} ] },
126 HASH => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) } },
127 ARRAY => {
128 SCALAR => sub { [ @{$_[0]}, $_[1] ] },
129 ARRAY => sub { [ @{$_[0]}, @{$_[1]} ] },
130 HASH => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) } },
131 HASH => {
132 SCALAR => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
133 ARRAY => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
134 HASH => sub { _merge_hashes( $_[0], $_[1] ) } }
135 );
136
137 my %behaviors = (
138 LEFT_PRECEDENT => \%left_precedent,
139 RIGHT_PRECEDENT => \%right_precedent,
140 STORAGE_PRECEDENT => \%storage_precedent,
141 RETAINMENT_PRECEDENT => \%retainment_precedent
142 );
143
144 my $merge_behavior = 'LEFT_PRECEDENT';
145 my $merge_matrix = \%{ $behaviors{ $merge_behavior } };
146
147 my $clone_behavior = 1;
148
149 sub set_behavior {
150 my $value = uc(shift);
151 die "Behavior must be one of : " , join ' ', keys %behaviors
152 unless exists $behaviors{ $value };
153 $merge_behavior = $value;
154 $merge_matrix = \%{ $behaviors{ $merge_behavior } };
155 }
156
157 sub get_behavior {
158 return $merge_behavior;
159 }
160
161 sub specify_behavior {
162 my $matrix = shift;
163 my $name = shift || "user defined";
164 my @required = qw ( SCALAR ARRAY HASH );
165
166 foreach my $left ( @required ) {
167 foreach my $right ( @required ) {
168 die "Behavior does not specify action for $left merging with $right"
169 unless exists $matrix->{ $left }->{ $right };
170 }
171 }
172
173 $merge_behavior = $name;
174 $merge_matrix = $matrix;
175 }
176
177 sub set_clone_behavior {
178 my $temp = shift;
179 $clone_behavior = ( $temp ) ? 1 : 0;
180 }
181
182 sub get_clone_behavior {
183 return $clone_behavior;
184 }
185
186 sub merge {
187 my ( $left, $right ) = ( shift, shift );
188
189 # For the general use of this module, we want to create duplicates
190 # of all data that is merged. This behavior can be shut off, but
191 # can mess havoc if references are used heavily.
192
193 my ( $lefttype, $righttype );
194 if ( !defined( $left ) ) { # Perl 5.005 compatibility
195 $lefttype = 'SCALAR';
196 } elsif ( UNIVERSAL::isa( $left, 'HASH' ) ) {
197 $lefttype = 'HASH';
198 } elsif ( UNIVERSAL::isa( $left, 'ARRAY' ) ) {
199 $lefttype = 'ARRAY';
200 } else {
201 $lefttype = 'SCALAR';
202 }
203
204 if ( !defined( $right ) ) { # Perl 5.005 compatibility
205 $righttype = 'SCALAR';
206 } elsif ( UNIVERSAL::isa( $right, 'HASH' ) ) {
207 $righttype = 'HASH';
208 } elsif ( UNIVERSAL::isa( $right, 'ARRAY' ) ) {
209 $righttype = 'ARRAY';
210 } else {
211 $righttype = 'SCALAR';
212 }
213
214 if ( $clone_behavior ) {
215 $left = _my_clone ( $left, 1 );
216 $right = _my_clone ( $right, 1 );
217 }
218
219 return &{ $merge_matrix->{ $lefttype }->{ $righttype }}
220 ( $left, $right );
221 }
222
223 # This does a straight merge of hashes, delegating the merge-specific
224 # work to 'merge'
225
226 sub _merge_hashes {
227 my ( $left, $right ) = ( shift, shift );
228 die "Arguments for _merge_hashes must be hash references" unless
229 UNIVERSAL::isa( $left, 'HASH' ) && UNIVERSAL::isa( $right, 'HASH' );
230
231 my %newhash;
232 foreach my $leftkey ( keys %$left ) {
233 if ( exists $right->{ $leftkey } ) {
234 $newhash{ $leftkey } =
235 merge ( $left->{ $leftkey }, $right->{ $leftkey } )
236 } else {
237 $newhash{ $leftkey } =
238 ( $clone_behavior ) ? _my_clone( $left->{ $leftkey } )
239 : $left->{ $leftkey };
240 }
241 }
242 foreach my $rightkey ( keys %$right ) {
243 if ( !exists $left->{ $rightkey } ) {
244 $newhash{ $rightkey } =
245 ( $clone_behavior ) ? _my_clone( $right->{ $rightkey } )
246 : $right->{ $rightkey };
247 }
248 }
249 return \%newhash;
250 }
251
252 # Given a scalar or an array, creates a new hash where for each item in
253 # the passed scalar or array, the key is equal to the value. Returns
254 # this new hash
255
256 sub _hashify {
257 my $arg = shift;
258 die "Arguement for _hashify must not be a HASH ref" if
259 UNIVERSAL::isa( $arg, 'HASH' );
260
261 my %newhash;
262 if ( UNIVERSAL::isa( $arg, 'ARRAY' ) ) {
263 foreach my $item ( @$arg ) {
264 my $suffix = 2;
265 my $name = $item;
266 while ( exists $newhash{ $name } ) {
267 $name = $item . $suffix++;
268 }
269 $newhash{ $name } = $item;
270 }
271 } else {
272 $newhash{ $arg } = $arg;
273 }
274 return \%newhash;
275 }
276
277 # This adds some checks to the clone process, to deal with problems that
278 # the current distro of ActiveState perl has (specifically, it uses 0.09
279 # of Clone, which does not support the cloning of scalars). This simply
280 # wraps around clone as to prevent a scalar from being cloned via a
281 # Clone 0.09 process. This might mean that CODEREFs and anything else
282 # not a HASH or ARRAY won't be cloned.
283
284 sub _my_clone {
285 my ( $arg, $depth ) = @_;
286 if ( !$CLONE_SUPPORT &&
287 !UNIVERSAL::isa( $arg, 'HASH' ) &&
288 !UNIVERSAL::isa( $arg, 'ARRAY' )) {
289 my $var = $arg; # Forced clone
290 return $var;
291 } else {
292 if ($depth ) {
293 return clone( $arg, $depth );
294 } else {
295 return clone( $arg );
296 }
297 }
298 }
299
300 1;
301 __END__
302
303 =head1 NAME
304
305 Hash::Merge - Merges arbitrarily deep hashes into a single hash
306
307 =head1 SYNOPSIS
308
309 use Hash::Merge qw( merge );
310 my %a = ( foo => 1,
311 bar => [ a, b, e ],
312 querty => { bob => alice } );
313 my %b = ( foo => 2,
314 bar => [ c, d ],
315 querty => { ted => margeret } );
316
317 my %c = %{ merge( \%a, \%b ) };
318
319 Hash::Merge::set_behavior( RIGHT_PRECEDENT );
320
321 # This is the same as above
322
323 Hash::Merge::specify_behavior( {
324 SCALAR => {
325 SCALAR => sub { $_[1] },
326 ARRAY => sub { [ $_[0], @{$_[1]} ] },
327 HASH => sub { $_[1] } },
328 ARRAY => {
329 SCALAR => sub { $_[1] },
330 ARRAY => sub { [ @{$_[0]}, @{$_[1]} ] },
331 HASH => sub { $_[1] } },
332 HASH => {
333 SCALAR => sub { $_[1] },
334 ARRAY => sub { [ values %{$_[0]}, @{$_[1]} ] },
335 HASH => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) } }
336 }, "My Behavior" );
337
338 =head1 DESCRIPTION
339
340 Hash::Merge merges two arbitrarily deep hashes into a single hash. That
341 is, at any level, it will add non-conflicting key-value pairs from one
342 hash to the other, and follows a set of specific rules when there are key
343 value conflicts (as outlined below). The hash is followed recursively,
344 so that deeply nested hashes that are at the same level will be merged
345 when the parent hashes are merged. B<Please note that self-referencing
346 hashes, or recursive references, are not handled well by this method.>
347
348 Values in hashes are considered to be either ARRAY references,
349 HASH references, or otherwise are treated as SCALARs. By default, the
350 data passed to the merge function will be cloned using the Clone module;
351 however, if necessary, this behavior can be changed to use as many of
352 the original values as possible. (See C<set_clone_behavior>).
353
354 Because there are a number of possible ways that one may want to merge
355 values when keys are conflicting, Hash::Merge provides several preset
356 methods for your convenience, as well as a way to define you own.
357 These are (currently):
358
359 =over
360
361 =item Left Precedence
362
363 The values buried in the left hash will never
364 be lost; any values that can be added from the right hash will be
365 attempted.
366
367 =item Right Precedence
368
369 Same as Left Precedence, but with the right
370 hash values never being lost
371
372 =item Storage Precedence
373
374 If conflicting keys have two different
375 storage mediums, the 'bigger' medium will win; arrays are preferred over
376 scalars, hashes over either. The other medium will try to be fitted in
377 the other, but if this isn't possible, the data is dropped.
378
379 =item Retainment Precedence
380
381 No data will be lost; scalars will be joined
382 with arrays, and scalars and arrays will be 'hashified' to fit them into
383 a hash.
384
385 =back
386
387 Specific descriptions of how these work are detailed below.
388
389 =over
390
391 =item merge ( <hashref>, <hashref> )
392
393 Merges two hashes given the rules specified. Returns a reference to
394 the new hash.
395
396 =item _hashify( <scalar>|<arrayref> ) -- INTERNAL FUNCTION
397
398 Returns a reference to a hash created from the scalar or array reference,
399 where, for the scalar value, or each item in the array, there is a key
400 and it's value equal to that specific value. Example, if you pass scalar
401 '3', the hash will be { 3 => 3 }.
402
403 =item _merge_hashes( <hashref>, <hashref> ) -- INTERNAL FUNCTION
404
405 Actually does the key-by-key evaluation of two hashes and returns
406 the new merged hash. Note that this recursively calls C<merge>.
407
408 =item set_clone_behavior( <scalar> )
409
410 Sets how the data cloning is handled by Hash::Merge. If this is true,
411 then data will be cloned; if false, then original data will be used
412 whenever possible. By default, cloning is on (set to true).
413
414 =item get_clone_behavior( )
415
416 Returns the current behavior for data cloning.
417
418 =item set_behavior( <scalar> )
419
420 Specify which built-in behavior for merging that is desired. The scalar
421 must be one of those given below.
422
423 =item get_behavior( )
424
425 Returns the behavior that is currently in use by Hash::Merge.
426
427 =item specify_behavior( <hashref>, [<name>] )
428
429 Specify a custom merge behavior for Hash::Merge. This must be a hashref
430 defined with (at least) 3 keys, SCALAR, ARRAY, and HASH; each of those
431 keys must have another hashref with (at least) the same 3 keys defined.
432 Furthermore, the values in those hashes must be coderefs. These will be
433 called with two arguments, the left and right values for the merge.
434 Your coderef should return either a scalar or an array or hash reference
435 as per your planned behavior. If necessary, use the functions
436 _hashify and _merge_hashes as helper functions for these. For example,
437 if you want to add the left SCALAR to the right ARRAY, you can have your
438 behavior specification include:
439
440 %spec = ( ...SCALAR => { ARRAY => sub { [ $_[0], @$_[1] ] }, ... } } );
441
442 Note that you can import _hashify and _merge_hashes into your program's
443 namespace with the 'custom' tag.
444
445 =back
446
447 =head1 BUILT-IN BEHAVIORS
448
449 Here is the specifics on how the current internal behaviors are called,
450 and what each does. Assume that the left value is given as $a, and
451 the right as $b (these are either scalars or appropriate references)
452
453 LEFT TYPE RIGHT TYPE LEFT_PRECEDENT RIGHT_PRECEDENT
454 SCALAR SCALAR $a $b
455 SCALAR ARRAY $a ( $a, @$b )
456 SCALAR HASH $a %$b
457 ARRAY SCALAR ( @$a, $b ) $b
458 ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b )
459 ARRAY HASH ( @$a, values %$b ) %$b
460 HASH SCALAR %$a $b
461 HASH ARRAY %$a ( values %$a, @$b )
462 HASH HASH merge( %$a, %$b ) merge( %$a, %$b )
463
464 LEFT TYPE RIGHT TYPE STORAGE_PRECEDENT RETAINMENT_PRECEDENT
465 SCALAR SCALAR $a ( $a ,$b )
466 SCALAR ARRAY ( $a, @$b ) ( $a, @$b )
467 SCALAR HASH %$b merge( hashify( $a ), %$b )
468 ARRAY SCALAR ( @$a, $b ) ( @$a, $b )
469 ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b )
470 ARRAY HASH %$b merge( hashify( @$a ), %$b )
471 HASH SCALAR %$a merge( %$a, hashify( $b ) )
472 HASH ARRAY %$a merge( %$a, hashify( @$b ) )
473 HASH HASH merge( %$a, %$b ) merge( %$a, %$b )
474
475
476 (*) note that merge calls _merge_hashes, hashify calls _hashify.
477
478 =head1 CAVEATS
479
480 This will not handle self-referencing/recursion within hashes well.
481 Plans for a future version include incorporate deep recursion protection.
482
483 As of Feb 16, 2002, ActiveState Perl's PPM of Clone.pm is only at
484 0.09. This version does not support the cloning of scalars if passed
485 to the function. This is fixed by 0.10 (and currently, Clone.pm is at
486 0.13). So while most other users can upgrade their Clone.pm
487 appropriately (and I could put this as a requirement into the
488 Makefile.PL), those using ActiveState would lose out on the ability to
489 use this module. (Clone.pm is not pure perl, so it's not simply a
490 matter of moving the newer file into place). Thus, for the time
491 being, a check is done at the start of loading of this module to see
492 if a newer version of clone is around. Then, all cloning calls have
493 been wrapped in the internal _my_clone function to block any scalar
494 clones if Clone.pm is too old. However, this also prevents the
495 cloning of anything that isn't a hash or array under the same
496 conditions. Once ActiveState updates their Clone, I'll remove this
497 wrapper.
498
499 =head1 AUTHOR
500
501 Michael K. Neylon E<lt>mneylon-pm@masemware.comE<gt>
502
503 =head1 COPYRIGHT
504
505 Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved.
506
507 This library is free software. You can redistribute it and/or modify it
508 under the same terms as Perl itself.
509
510 =head1 HISTORY
511
512 $Log: Merge.pm,v $
513 Revision 0.07 2002/02/19 00:21:27 mneylon
514 Fixed problem with ActiveState Perl's Clone.pm implementation.
515 Fixed typo in POD.
516 Fixed formatting of code in general.
517
518 Revision 0.06.01.2 2002/02/17 03:18:20 mneylon
519 Fixed problem with ActiveState Perl's Clone.pm implementation.
520 Fixed typo in POD.
521 Fixed formatting of code in general.
522
523 Revision 0.06.01.1 2002/02/17 02:48:54 mneylon
524 Branched version.
525
526 Revision 0.06 2001/11/10 03:30:34 mneylon
527 Version 0.06 release (and more CVS fixes)
528
529 Revision 0.05.02.2 2001/11/10 03:22:58 mneylon
530 Updated documentation
531
532 Revision 0.05.02.1 2001/11/08 00:14:48 mneylon
533 Fixing CVS problems
534
535 Revision 0.05.01.1 2001/11/06 03:26:56 mneylon
536 Fixed some undefined variable problems for 5.005.
537 Added cloning of data and set/get_clone_behavior functions
538 Added associated testing of data cloning
539 Fixed some problems with POD
540
541 Revision 0.05 2001/11/02 02:15:54 mneylon
542 Yet another fix to Test::More requirement (=> 0.33)
543
544 Revision 0.04 2001/10/31 03:59:03 mneylon
545 Forced Test::More requirement in makefile
546 Fixed problems with pod documentation
547
548 Revision 0.03 2001/10/28 23:36:12 mneylon
549 CPAN Release with CVS fixes
550
551 Revision 0.02 2001/10/28 23:05:03 mneylon
552 CPAN release
553
554 =cut

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed