| 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 |
|
|
$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 |
Parent Directory
| 
Revision Log
