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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Thu Feb 20 05:53:44 2003 UTC (21 years, 8 months ago) by joko
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +11 -2 lines
+ sub set_mixin_behavior

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

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