r76902 - in /branches/upstream/libhash-merge-perl: ./ current/ current/Changes current/MANIFEST current/META.yml current/Makefile.PL current/Merge.pm current/README current/t/ current/t/merge.t current/t/oo.t
fabreg-guest at users.alioth.debian.org
fabreg-guest at users.alioth.debian.org
Fri Jul 1 22:47:37 UTC 2011
Author: fabreg-guest
Date: Fri Jul 1 22:47:28 2011
New Revision: 76902
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=76902
Log:
[svn-inject] Installing original source of libhash-merge-perl (0.12)
Added:
branches/upstream/libhash-merge-perl/
branches/upstream/libhash-merge-perl/current/
branches/upstream/libhash-merge-perl/current/Changes
branches/upstream/libhash-merge-perl/current/MANIFEST
branches/upstream/libhash-merge-perl/current/META.yml
branches/upstream/libhash-merge-perl/current/Makefile.PL
branches/upstream/libhash-merge-perl/current/Merge.pm (with props)
branches/upstream/libhash-merge-perl/current/README
branches/upstream/libhash-merge-perl/current/t/
branches/upstream/libhash-merge-perl/current/t/merge.t (with props)
branches/upstream/libhash-merge-perl/current/t/oo.t (with props)
Added: branches/upstream/libhash-merge-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/Changes?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/Changes (added)
+++ branches/upstream/libhash-merge-perl/current/Changes Fri Jul 1 22:47:28 2011
@@ -1,0 +1,69 @@
+Revision history for Perl extension Hash::Merge.
+
+0.12 Mon Feb 15 19:23:52 CST 2010
+ Thanks to MONS for addressing these:
+ - rt 39183 fallback to Clone::PP if needed/possible
+ - rt 43056 OO support for more sane behavior non-trampling
+
+ This version is a cleaned up version of MONS' patch in rt 43056 plus:
+
+ Added tests for OO behavior.
+ Cleaned up POD a little
+ perltidy
+
+0.11 Thu Apr 9 08:32:12 2009
+ - fix ||= typo, thanks GWADEJ or bringing it to my attention
+
+0.10 Sun Apr 8 23:26:12 2007
+ - DMUEY rt.cpan.org id 13390
+ - POD Synopsis cleanup
+
+0.09 Tue Apr 3 20:48:21 2007
+ - DMUEY: Merge.pm - refactored code as per rt.cpan.org id 26076 (passes all tests)
+ - DMUEY: removed 'HISTORY' from POD since its in the Changes file (IE less room to get the data out of sync)
+ - DMUEY: Makefile.PL - general cleanup, note pinned to Clone prereq
+ - DMUEY: README: Updated version from 0.07 to 0.09
+
+$Log: Changes,v $
+Revision 0.08 2006/08/08 21:46:00 mneylon
+Fixed hash reference issue (per Perl 5.8.8) in test sequence
+
+Revision 0.07 2002/02/19 00:21:27 mneylon
+Fixed problem with ActiveState Perl's Clone.pm implementation.
+Fixed typo in POD.
+Fixed formatting of code in general.
+
+Revision 0.06.01.1 2002/02/17 02:48:54 mneylon
+Branched version.
+
+Revision 0.06 2001/11/10 03:30:34 mneylon
+Version 0.06 release (and more CVS fixes)
+
+Revision 0.05.02.1 2001/11/08 00:14:47 mneylon
+Fixing CVS problems
+
+Revision 0.05.01.2 2001/11/06 03:26:56 mneylon
+Fixed some undefined variable problems for 5.005.
+Added cloning of data and set/get_clone_behavior functions
+Added associated testing of data cloning
+Fixed some problems with POD
+
+Revision 0.05 2001/11/02 02:15:54 mneylon
+Yet another fix to Test::More requirement (=> 0.33)
+
+Revision 0.04 2001/10/31 03:59:03 mneylon
+Forced Test::More requirement in makefile
+Fixed problems with pod documentation
+
+Revision 0.03 2001/10/28 23:36:12 mneylon
+CPAN Release with CVS fixes
+
+Revision 0.02 2001/10/28 23:05:03 mneylon
+CPAN release
+
+Revision 0.01.1.1 2001/10/23 03:01:34 mneylon
+Slight fixes
+
+Revision 0.01 2001/10/23 03:00:21 mneylon
+Initial Release to PerlMonks
+
Added: branches/upstream/libhash-merge-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/MANIFEST?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/MANIFEST (added)
+++ branches/upstream/libhash-merge-perl/current/MANIFEST Fri Jul 1 22:47:28 2011
@@ -1,0 +1,8 @@
+Changes
+Makefile.PL
+MANIFEST
+Merge.pm
+README
+t/merge.t
+t/oo.t
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libhash-merge-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/META.yml?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/META.yml (added)
+++ branches/upstream/libhash-merge-perl/current/META.yml Fri Jul 1 22:47:28 2011
@@ -1,0 +1,23 @@
+--- #YAML:1.0
+name: Hash-Merge
+version: 0.12
+abstract: Merges arbitrarily deep hashes into a single hash
+author:
+ - Michael K. Neylon <mneylon-pm at masemware.com
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ Clone: 0
+ Test::More: 0.33
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.56
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Added: branches/upstream/libhash-merge-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/Makefile.PL?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/Makefile.PL (added)
+++ branches/upstream/libhash-merge-perl/current/Makefile.PL Fri Jul 1 22:47:28 2011
@@ -1,0 +1,13 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'Hash::Merge',
+ 'VERSION_FROM' => 'Merge.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0.33,
+ 'Clone' => 0, # still require it here, just not when using the module without clone on
+ },
+ ($] >= 5.005 ?
+ (ABSTRACT_FROM => 'Merge.pm',
+ AUTHOR => 'Michael K. Neylon <mneylon-pm at masemware.com') : ()),
+);
Added: branches/upstream/libhash-merge-perl/current/Merge.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/Merge.pm?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/Merge.pm (added)
+++ branches/upstream/libhash-merge-perl/current/Merge.pm Fri Jul 1 22:47:28 2011
@@ -1,0 +1,561 @@
+package Hash::Merge;
+
+use strict;
+use warnings;
+use Carp;
+
+use base 'Exporter';
+use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $context);
+
+my ( $GLOBAL, $clone );
+
+$VERSION = '0.12';
+ at EXPORT_OK = qw( merge _hashify _merge_hashes );
+%EXPORT_TAGS = ( 'custom' => [qw( _hashify _merge_hashes )] );
+
+$GLOBAL = {};
+bless $GLOBAL, __PACKAGE__;
+$context = $GLOBAL; # $context is a variable for merge and _merge_hashes. used by functions to respect calling context
+
+$GLOBAL->{'behaviors'} = {
+ 'LEFT_PRECEDENT' => {
+ 'SCALAR' => {
+ 'SCALAR' => sub { $_[0] },
+ 'ARRAY' => sub { $_[0] },
+ 'HASH' => sub { $_[0] },
+ },
+ 'ARRAY' => {
+ 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
+ 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
+ 'HASH' => sub { [ @{ $_[0] }, values %{ $_[1] } ] },
+ },
+ 'HASH' => {
+ 'SCALAR' => sub { $_[0] },
+ 'ARRAY' => sub { $_[0] },
+ 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
+ },
+ },
+
+ 'RIGHT_PRECEDENT' => {
+ 'SCALAR' => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'ARRAY' => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'HASH' => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ values %{ $_[0] }, @{ $_[1] } ] },
+ 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
+ },
+ },
+
+ 'STORAGE_PRECEDENT' => {
+ 'SCALAR' => {
+ 'SCALAR' => sub { $_[0] },
+ 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'ARRAY' => {
+ 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
+ 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'HASH' => {
+ 'SCALAR' => sub { $_[0] },
+ 'ARRAY' => sub { $_[0] },
+ 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
+ },
+ },
+
+ 'RETAINMENT_PRECEDENT' => {
+ 'SCALAR' => {
+ 'SCALAR' => sub { [ $_[0], $_[1] ] },
+ 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
+ 'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
+ },
+ 'ARRAY' => {
+ 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
+ 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
+ 'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
+ },
+ 'HASH' => {
+ 'SCALAR' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
+ 'ARRAY' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
+ 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
+ },
+ },
+};
+
+$GLOBAL->{'behavior'} = 'LEFT_PRECEDENT';
+$GLOBAL->{'matrix'} = $GLOBAL->{behaviors}{ $GLOBAL->{'behavior'} };
+$GLOBAL->{'clone'} = 1;
+
+sub _get_obj {
+ if ( my $type = ref $_[0] ) {
+ return shift() if $type eq __PACKAGE__ || eval { $_[0]->isa(__PACKAGE__) };
+ }
+
+ return $context;
+}
+
+sub new {
+ my $pkg = shift;
+ $pkg = ref $pkg || $pkg;
+ my $beh = shift || $context->{'behavior'};
+
+ croak "Behavior '$beh' does not exist" if !exists $context->{'behaviors'}{$beh};
+
+ return bless {
+ 'behavior' => $beh,
+ 'matrix' => $context->{'behaviors'}{$beh},
+ }, $pkg;
+}
+
+sub set_behavior {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ my $value = uc(shift);
+ if ( !exists $self->{'behaviors'}{$value} and !exists $GLOBAL->{'behaviors'}{$value} ) {
+ carp 'Behavior must be one of : ' . join( ', ', keys %{ $self->{'behaviors'} }, keys %{ $GLOBAL->{'behaviors'}{$value} } );
+ return;
+ }
+ my $oldvalue = $self->{'behavior'};
+ $self->{'behavior'} = $value;
+ $self->{'matrix'} = $self->{'behaviors'}{$value} || $GLOBAL->{'behaviors'}{$value};
+ return $oldvalue; # Use classic POSIX pattern for get/set: set returns previous value
+}
+
+sub get_behavior {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ return $self->{'behavior'};
+}
+
+sub specify_behavior {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ my ( $matrix, $name ) = @_;
+ $name ||= 'user defined';
+ if ( exists $self->{'behaviors'}{$name} ) {
+ carp "Behavior '$name' was already defined. Please take another name";
+ return;
+ }
+
+ my @required = qw( SCALAR ARRAY HASH );
+
+ foreach my $left (@required) {
+ foreach my $right (@required) {
+ if ( !exists $matrix->{$left}->{$right} ) {
+ carp "Behavior does not specify action for '$left' merging with '$right'";
+ return;
+ }
+ }
+ }
+
+ $self->{'behavior'} = $name;
+ $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
+}
+
+sub set_clone_behavior {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ my $oldvalue = $self->{'clone'};
+ $self->{'clone'} = shift() ? 1 : 0;
+ return $oldvalue;
+}
+
+sub get_clone_behavior {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ return $self->{'clone'};
+}
+
+sub merge {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+
+ my ( $left, $right ) = @_;
+
+ # For the general use of this module, we want to create duplicates
+ # of all data that is merged. This behavior can be shut off, but
+ # can create havoc if references are used heavily.
+
+ my $lefttype =
+ ref $left eq 'HASH' ? 'HASH'
+ : ref $left eq 'ARRAY' ? 'ARRAY'
+ : 'SCALAR';
+
+ my $righttype =
+ ref $right eq 'HASH' ? 'HASH'
+ : ref $right eq 'ARRAY' ? 'ARRAY'
+ : 'SCALAR';
+
+ if ( $self->{'clone'} ) {
+ $left = _my_clone( $left, 1 );
+ $right = _my_clone( $right, 1 );
+ }
+
+ local $context = $self;
+ return $self->{'matrix'}->{$lefttype}{$righttype}->( $left, $right );
+}
+
+# This does a straight merge of hashes, delegating the merge-specific
+# work to 'merge'
+
+sub _merge_hashes {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+
+ my ( $left, $right ) = ( shift, shift );
+ if ( ref $left ne 'HASH' || ref $right ne 'HASH' ) {
+ carp 'Arguments for _merge_hashes must be hash references';
+ return;
+ }
+
+ my %newhash;
+ foreach my $leftkey ( keys %$left ) {
+ if ( exists $right->{$leftkey} ) {
+ $newhash{$leftkey} = $self->merge( $left->{$leftkey}, $right->{$leftkey} );
+ }
+ else {
+ $newhash{$leftkey} = $self->{clone} ? $self->_my_clone( $left->{$leftkey} ) : $left->{$leftkey};
+ }
+ }
+
+ foreach my $rightkey ( keys %$right ) {
+ if ( !exists $left->{$rightkey} ) {
+ $newhash{$rightkey} = $self->{clone} ? $self->_my_clone( $right->{$rightkey} ) : $right->{$rightkey};
+ }
+ }
+
+ return \%newhash;
+}
+
+# Given a scalar or an array, creates a new hash where for each item in
+# the passed scalar or array, the key is equal to the value. Returns
+# this new hash
+
+sub _hashify {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ my $arg = shift;
+ if ( ref $arg eq 'HASH' ) {
+ carp 'Arguement for _hashify must not be a HASH ref';
+ return;
+ }
+
+ my %newhash;
+ if ( ref $arg eq 'ARRAY' ) {
+ foreach my $item (@$arg) {
+ my $suffix = 2;
+ my $name = $item;
+ while ( exists $newhash{$name} ) {
+ $name = $item . $suffix++;
+ }
+ $newhash{$name} = $item;
+ }
+ }
+ else {
+ $newhash{$arg} = $arg;
+ }
+ return \%newhash;
+}
+
+# This adds some checks to the clone process, to deal with problems that
+# the current distro of ActiveState perl has (specifically, it uses 0.09
+# of Clone, which does not support the cloning of scalars). This simply
+# wraps around clone as to prevent a scalar from being cloned via a
+# Clone 0.09 process. This might mean that CODEREFs and anything else
+# not a HASH or ARRAY won't be cloned.
+
+# $clone is global, which should point to coderef
+
+sub _my_clone {
+ my $self = &_get_obj; # '&' + no args modifies current @_
+ my ( $arg, $depth ) = @_;
+
+ if ( $self->{clone} && !$clone ) {
+ if ( eval { require Clone; 1 } ) {
+ $clone = sub {
+ if ( !( $Clone::VERSION || 0 ) > 0.09
+ && ref $_[0] ne 'HASH'
+ && ref $_[0] ne 'ARRAY' ) {
+ my $var = shift; # Forced clone
+ return $var;
+ }
+ Clone::clone( shift, $depth );
+ };
+ }
+ elsif ( eval { require Storable; 1 } ) {
+ $clone = sub {
+ my $var = shift; # Forced clone
+ return $var if !ref($var);
+ Storable::dclone($var);
+ };
+ }
+ elsif ( eval { require Clone::PP; 1 } ) {
+ $clone = sub {
+ my $var = shift; # Forced clone
+ return $var if !ref($var);
+ Clone::PP::clone( $var, $depth );
+ };
+ }
+ else {
+ croak "Can't load Clone, Storable, or Clone::PP for cloning purpose";
+ }
+ }
+
+ if ( $self->{'clone'} ) {
+ return $clone->($arg);
+ }
+ else {
+ return $arg;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Hash::Merge - Merges arbitrarily deep hashes into a single hash
+
+=head1 SYNOPSIS
+
+ use Hash::Merge qw( merge );
+ my %a = (
+ 'foo' => 1,
+ 'bar' => [ qw( a b e ) ],
+ 'querty' => { 'bob' => 'alice' },
+ );
+ my %b = (
+ 'foo' => 2,
+ 'bar' => [ qw(c d) ],
+ 'querty' => { 'ted' => 'margeret' },
+ );
+
+ my %c = %{ merge( \%a, \%b ) };
+
+ Hash::Merge::set_behavior( 'RIGHT_PRECEDENT' );
+
+ # This is the same as above
+
+ Hash::Merge::specify_behavior(
+ {
+ 'SCALAR' => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ $_[0], @{$_[1]} ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'ARRAY => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ @{$_[0]}, @{$_[1]} ] },
+ 'HASH' => sub { $_[1] },
+ },
+ 'HASH' => {
+ 'SCALAR' => sub { $_[1] },
+ 'ARRAY' => sub { [ values %{$_[0]}, @{$_[1]} ] },
+ 'HASH' => sub { Hash::Merge::_merge_hashes( $_[0], $_[1] ) },
+ },
+ },
+ 'My Behavior',
+ );
+
+ # Also there is OO interface.
+
+ my $merge = Hash::Merge->new( 'LEFT_PRECEDENT' );
+ my %c = %{ $merge->merge( \%a, \%b ) };
+
+ # All behavioral changes (e.g. $merge->set_behavior(...)), called on an object remain specific to that object
+ # The legacy "Global Setting" behavior is respected only when new called as a non-OO function.
+
+=head1 DESCRIPTION
+
+Hash::Merge merges two arbitrarily deep hashes into a single hash. That
+is, at any level, it will add non-conflicting key-value pairs from one
+hash to the other, and follows a set of specific rules when there are key
+value conflicts (as outlined below). The hash is followed recursively,
+so that deeply nested hashes that are at the same level will be merged
+when the parent hashes are merged. B<Please note that self-referencing
+hashes, or recursive references, are not handled well by this method.>
+
+Values in hashes are considered to be either ARRAY references,
+HASH references, or otherwise are treated as SCALARs. By default, the
+data passed to the merge function will be cloned using the Clone module;
+however, if necessary, this behavior can be changed to use as many of
+the original values as possible. (See C<set_clone_behavior>).
+
+Because there are a number of possible ways that one may want to merge
+values when keys are conflicting, Hash::Merge provides several preset
+methods for your convenience, as well as a way to define you own.
+These are (currently):
+
+=over
+
+=item Left Precedence
+
+This is the default behavior.
+
+The values buried in the left hash will never
+be lost; any values that can be added from the right hash will be
+attempted.
+
+ my $merge = Hash::Merge->new();
+ my $merge = Hash::Merge->new('LEFT_PRECEDENT');
+ $merge->set_set_behavior('LEFT_PRECEDENT')
+ Hash::Merge::set_set_behavior('LEFT_PRECEDENT')
+
+=item Right Precedence
+
+Same as Left Precedence, but with the right
+hash values never being lost
+
+ my $merge = Hash::Merge->new('RIGHT_PRECEDENT');
+ $merge->set_set_behavior('RIGHT_PRECEDENT')
+ Hash::Merge::set_set_behavior('RIGHT_PRECEDENT')
+
+=item Storage Precedence
+
+If conflicting keys have two different
+storage mediums, the 'bigger' medium will win; arrays are preferred over
+scalars, hashes over either. The other medium will try to be fitted in
+the other, but if this isn't possible, the data is dropped.
+
+ my $merge = Hash::Merge->new('STORAGE_PRECEDENT');
+ $merge->set_set_behavior('STORAGE_PRECEDENT')
+ Hash::Merge::set_set_behavior('STORAGE_PRECEDENT')
+
+=item Retainment Precedence
+
+No data will be lost; scalars will be joined
+with arrays, and scalars and arrays will be 'hashified' to fit them into
+a hash.
+
+ my $merge = Hash::Merge->new('RETAINMENT_PRECEDENT');
+ $merge->set_set_behavior('RETAINMENT_PRECEDENT')
+ Hash::Merge::set_set_behavior('RETAINMENT_PRECEDENT')
+
+=back
+
+Specific descriptions of how these work are detailed below.
+
+=over
+
+=item merge ( <hashref>, <hashref> )
+
+Merges two hashes given the rules specified. Returns a reference to
+the new hash.
+
+=item _hashify( <scalar>|<arrayref> ) -- INTERNAL FUNCTION
+
+Returns a reference to a hash created from the scalar or array reference,
+where, for the scalar value, or each item in the array, there is a key
+and it's value equal to that specific value. Example, if you pass scalar
+'3', the hash will be { 3 => 3 }.
+
+=item _merge_hashes( <hashref>, <hashref> ) -- INTERNAL FUNCTION
+
+Actually does the key-by-key evaluation of two hashes and returns
+the new merged hash. Note that this recursively calls C<merge>.
+
+=item set_clone_behavior( <scalar> )
+
+Sets how the data cloning is handled by Hash::Merge. If this is true,
+then data will be cloned; if false, then original data will be used
+whenever possible. By default, cloning is on (set to true).
+
+=item get_clone_behavior( )
+
+Returns the current behavior for data cloning.
+
+=item set_behavior( <scalar> )
+
+Specify which built-in behavior for merging that is desired. The scalar
+must be one of those given below.
+
+=item get_behavior( )
+
+Returns the behavior that is currently in use by Hash::Merge.
+
+=item specify_behavior( <hashref>, [<name>] )
+
+Specify a custom merge behavior for Hash::Merge. This must be a hashref
+defined with (at least) 3 keys, SCALAR, ARRAY, and HASH; each of those
+keys must have another hashref with (at least) the same 3 keys defined.
+Furthermore, the values in those hashes must be coderefs. These will be
+called with two arguments, the left and right values for the merge.
+Your coderef should return either a scalar or an array or hash reference
+as per your planned behavior. If necessary, use the functions
+_hashify and _merge_hashes as helper functions for these. For example,
+if you want to add the left SCALAR to the right ARRAY, you can have your
+behavior specification include:
+
+ %spec = ( ...SCALAR => { ARRAY => sub { [ $_[0], @$_[1] ] }, ... } } );
+
+Note that you can import _hashify and _merge_hashes into your program's
+namespace with the 'custom' tag.
+
+=back
+
+=head1 BUILT-IN BEHAVIORS
+
+Here is the specifics on how the current internal behaviors are called,
+and what each does. Assume that the left value is given as $a, and
+the right as $b (these are either scalars or appropriate references)
+
+ LEFT TYPE RIGHT TYPE LEFT_PRECEDENT RIGHT_PRECEDENT
+ SCALAR SCALAR $a $b
+ SCALAR ARRAY $a ( $a, @$b )
+ SCALAR HASH $a %$b
+ ARRAY SCALAR ( @$a, $b ) $b
+ ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b )
+ ARRAY HASH ( @$a, values %$b ) %$b
+ HASH SCALAR %$a $b
+ HASH ARRAY %$a ( values %$a, @$b )
+ HASH HASH merge( %$a, %$b ) merge( %$a, %$b )
+
+ LEFT TYPE RIGHT TYPE STORAGE_PRECEDENT RETAINMENT_PRECEDENT
+ SCALAR SCALAR $a ( $a ,$b )
+ SCALAR ARRAY ( $a, @$b ) ( $a, @$b )
+ SCALAR HASH %$b merge( hashify( $a ), %$b )
+ ARRAY SCALAR ( @$a, $b ) ( @$a, $b )
+ ARRAY ARRAY ( @$a, @$b ) ( @$a, @$b )
+ ARRAY HASH %$b merge( hashify( @$a ), %$b )
+ HASH SCALAR %$a merge( %$a, hashify( $b ) )
+ HASH ARRAY %$a merge( %$a, hashify( @$b ) )
+ HASH HASH merge( %$a, %$b ) merge( %$a, %$b )
+
+
+(*) note that merge calls _merge_hashes, hashify calls _hashify.
+
+=head1 CAVEATS
+
+This will not handle self-referencing/recursion within hashes well.
+Plans for a future version include incorporate deep recursion protection.
+
+As of Feb 16, 2002, ActiveState Perl's PPM of Clone.pm is only at
+0.09. This version does not support the cloning of scalars if passed
+to the function. This is fixed by 0.10 (and currently, Clone.pm is at
+0.13). So while most other users can upgrade their Clone.pm
+appropriately (and I could put this as a requirement into the
+Makefile.PL), those using ActiveState would lose out on the ability to
+use this module. (Clone.pm is not pure perl, so it's not simply a
+matter of moving the newer file into place). Thus, for the time
+being, a check is done at the start of loading of this module to see
+if a newer version of clone is around. Then, all cloning calls have
+been wrapped in the internal _my_clone function to block any scalar
+clones if Clone.pm is too old. However, this also prevents the
+cloning of anything that isn't a hash or array under the same
+conditions. Once ActiveState updates their Clone, I'll remove this
+wrapper.
+
+=head1 AUTHOR
+
+Michael K. Neylon E<lt>mneylon-pm at masemware.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Propchange: branches/upstream/libhash-merge-perl/current/Merge.pm
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhash-merge-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/README?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/README (added)
+++ branches/upstream/libhash-merge-perl/current/README Fri Jul 1 22:47:28 2011
@@ -1,0 +1,40 @@
+Hash/Merge version $Revision: 0.12 $
+=========================================
+
+Hash::Merge merges two arbitrarily deep hashes into a single hash. That
+is, at any level, it will add non-conflicting key-value pairs from one
+hash to the other, and follows a set of specific rules when there are key
+value conflicts (as outlined below). The hash is followed recursively,
+so that deeply nested hashes that are at the same level will be merged
+when the parent hashes are merged.
+
+Please see the POD for the module for additional information.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+DEPENDENCIES
+
+While this module doesn't depend on any other methods, the testing
+script does require Test::More.
+
+COPYRIGHT AND LICENCE
+
+Copyright (c) 2001 Michael K. Neylon. All rights reserved.
+
+This library is free software. You can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+ACKNOWLEDGEMENTS
+
+Thanks to:
+- Chuck Charbeneau for pointing out interference bugs from ActiveState
+- Jeff Fitzgibbon for pointing out inconsistance typo in POD
+- Daniel Muey for the v0.09 refactor to clean up the code
+- Daniel Muey for the v0.10 clean up the POD Synopsis
Added: branches/upstream/libhash-merge-perl/current/t/merge.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/t/merge.t?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/t/merge.t (added)
+++ branches/upstream/libhash-merge-perl/current/t/merge.t Fri Jul 1 22:47:28 2011
@@ -1,0 +1,109 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests=>45;
+use Hash::Merge qw( merge );
+
+my %left = ( ss => 'left',
+ sa => 'left',
+ sh => 'left',
+ as => [ 'l1', 'l2' ],
+ aa => [ 'l1', 'l2' ],
+ ah => [ 'l1', 'l2' ],
+ hs => { left=>1 },
+ ha => { left=>1 },
+ hh => { left=>1 } );
+
+my %right = ( ss => 'right',
+ as => 'right',
+ hs => 'right',
+ sa => [ 'r1', 'r2' ],
+ aa => [ 'r1', 'r2' ],
+ ha => [ 'r1', 'r2' ],
+ sh => { right=>1 },
+ ah => { right=>1 },
+ hh => { right=>1 } );
+
+# Test left precedence
+Hash::Merge::set_behavior( 'LEFT_PRECEDENT' );
+my %lp = %{merge( \%left, \%right )};
+
+is_deeply( $lp{ss}, 'left', 'Left Precedent - Scalar on Scalar' );
+is_deeply( $lp{sa}, 'left', 'Left Precedent - Scalar on Array' );
+is_deeply( $lp{sh}, 'left', 'Left Precedent - Scalar on Hash' );
+is_deeply( $lp{as}, [ 'l1', 'l2', 'right'], 'Left Precedent - Array on Scalar' );
+is_deeply( $lp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Left Precedent - Array on Array' );
+is_deeply( $lp{ah}, [ 'l1', 'l2', 1 ], 'Left Precedent - Array on Hash' );
+is_deeply( $lp{hs}, { left=>1 }, 'Left Precedent - Hash on Scalar' );
+is_deeply( $lp{ha}, { left=>1 }, 'Left Precedent - Hash on Array' );
+is_deeply( $lp{hh}, { left=>1, right=>1 }, 'Left Precedent - Hash on Hash' );
+
+
+Hash::Merge::set_behavior( 'RIGHT_PRECEDENT' );
+my %rp = %{merge( \%left, \%right )};
+
+is_deeply( $rp{ss}, 'right', 'Right Precedent - Scalar on Scalar' );
+is_deeply( $rp{sa}, [ 'left', 'r1', 'r2' ], 'Right Precedent - Scalar on Array' );
+is_deeply( $rp{sh}, { right=>1 }, 'Right Precedent - Scalar on Hash' );
+is_deeply( $rp{as}, 'right', 'Right Precedent - Array on Scalar' );
+is_deeply( $rp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Right Precedent - Array on Array' );
+is_deeply( $rp{ah}, { right=>1 }, 'Right Precedent - Array on Hash' );
+is_deeply( $rp{hs}, 'right', 'Right Precedent - Hash on Scalar' );
+is_deeply( $rp{ha}, [ 1, 'r1', 'r2' ], 'Right Precedent - Hash on Array' );
+is_deeply( $rp{hh}, { left=>1, right=>1 }, 'Right Precedent - Hash on Hash' );
+
+Hash::Merge::set_behavior( 'STORAGE_PRECEDENT' );
+my %sp = %{merge( \%left, \%right )};
+
+is_deeply( $sp{ss}, 'left', 'Storage Precedent - Scalar on Scalar' );
+is_deeply( $sp{sa}, [ 'left', 'r1', 'r2' ], 'Storage Precedent - Scalar on Array' );
+is_deeply( $sp{sh}, { right=>1 }, 'Storage Precedent - Scalar on Hash' );
+is_deeply( $sp{as}, [ 'l1', 'l2', 'right'], 'Storage Precedent - Array on Scalar' );
+is_deeply( $sp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Storage Precedent - Array on Array' );
+is_deeply( $sp{ah}, { right=>1 }, 'Storage Precedent - Array on Hash' );
+is_deeply( $sp{hs}, { left=>1 }, 'Storage Precedent - Hash on Scalar' );
+is_deeply( $sp{ha}, { left=>1 }, 'Storage Precedent - Hash on Array' );
+is_deeply( $sp{hh}, { left=>1, right=>1 }, 'Storage Precedent - Hash on Hash' );
+
+Hash::Merge::set_behavior( 'RETAINMENT_PRECEDENT' );
+my %rep = %{merge( \%left, \%right )};
+
+is_deeply( $rep{ss}, [ 'left', 'right' ], 'Retainment Precedent - Scalar on Scalar' );
+is_deeply( $rep{sa}, [ 'left', 'r1', 'r2' ], 'Retainment Precedent - Scalar on Array' );
+is_deeply( $rep{sh}, { left=>'left', right=>1 }, 'Retainment Precedent - Scalar on Hash' );
+is_deeply( $rep{as}, [ 'l1', 'l2', 'right'], 'Retainment Precedent - Array on Scalar' );
+is_deeply( $rep{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Retainment Precedent - Array on Array' );
+is_deeply( $rep{ah}, { l1=>'l1', l2=>'l2', right=>1 },
+ 'Retainment Precedent - Array on Hash' );
+is_deeply( $rep{hs}, { left=>1, right=>'right' },
+ 'Retainment Precedent - Hash on Scalar' );
+is_deeply( $rep{ha}, { left=>1, r1=>'r1', r2=>'r2' },
+ 'Retainment Precedent - Hash on Array' );
+is_deeply( $rep{hh}, { left=>1, right=>1 }, 'Retainment Precedent - Hash on Hash' );
+
+Hash::Merge::specify_behavior( {
+ SCALAR => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } },
+ ARRAY => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } },
+ HASH => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } }
+ }, "My Behavior" );
+
+my %cp = %{merge( \%left, \%right )};
+
+is_deeply( $cp{ss}, 'left', 'Custom Precedent - Scalar on Scalar' );
+is_deeply( $cp{sa}, 'left', 'Custom Precedent - Scalar on Array' );
+is_deeply( $cp{sh}, 'left', 'Custom Precedent - Scalar on Hash' );
+is_deeply( $cp{as}, [ 'l1', 'l2'], 'Custom Precedent - Array on Scalar' );
+is_deeply( $cp{aa}, [ 'l1', 'l2'], 'Custom Precedent - Array on Array' );
+is_deeply( $cp{ah}, [ 'l1', 'l2'], 'Custom Precedent - Array on Hash' );
+is_deeply( $cp{hs}, { left=>1 }, 'Custom Precedent - Hash on Scalar' );
+is_deeply( $cp{ha}, { left=>1 }, 'Custom Precedent - Hash on Array' );
+is_deeply( $cp{hh}, { left=>1 }, 'Custom Precedent - Hash on Hash' );
Propchange: branches/upstream/libhash-merge-perl/current/t/merge.t
------------------------------------------------------------------------------
svn:executable =
Added: branches/upstream/libhash-merge-perl/current/t/oo.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libhash-merge-perl/current/t/oo.t?rev=76902&op=file
==============================================================================
--- branches/upstream/libhash-merge-perl/current/t/oo.t (added)
+++ branches/upstream/libhash-merge-perl/current/t/oo.t Fri Jul 1 22:47:28 2011
@@ -1,0 +1,116 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests=>49;
+use Hash::Merge;
+
+my %left = ( ss => 'left',
+ sa => 'left',
+ sh => 'left',
+ as => [ 'l1', 'l2' ],
+ aa => [ 'l1', 'l2' ],
+ ah => [ 'l1', 'l2' ],
+ hs => { left=>1 },
+ ha => { left=>1 },
+ hh => { left=>1 } );
+
+my %right = ( ss => 'right',
+ as => 'right',
+ hs => 'right',
+ sa => [ 'r1', 'r2' ],
+ aa => [ 'r1', 'r2' ],
+ ha => [ 'r1', 'r2' ],
+ sh => { right=>1 },
+ ah => { right=>1 },
+ hh => { right=>1 } );
+
+# Test left precedence
+my $merge = Hash::Merge->new();
+ok($merge->get_behavior() eq 'LEFT_PRECEDENT', 'no arg default is LEFT_PRECEDENT');
+
+
+my %lp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $lp{ss}, 'left', 'Left Precedent - Scalar on Scalar' );
+is_deeply( $lp{sa}, 'left', 'Left Precedent - Scalar on Array' );
+is_deeply( $lp{sh}, 'left', 'Left Precedent - Scalar on Hash' );
+is_deeply( $lp{as}, [ 'l1', 'l2', 'right'], 'Left Precedent - Array on Scalar' );
+is_deeply( $lp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Left Precedent - Array on Array' );
+is_deeply( $lp{ah}, [ 'l1', 'l2', 1 ], 'Left Precedent - Array on Hash' );
+is_deeply( $lp{hs}, { left=>1 }, 'Left Precedent - Hash on Scalar' );
+is_deeply( $lp{ha}, { left=>1 }, 'Left Precedent - Hash on Array' );
+is_deeply( $lp{hh}, { left=>1, right=>1 }, 'Left Precedent - Hash on Hash' );
+
+ok($merge->set_behavior('RIGHT_PRECEDENT') eq 'LEFT_PRECEDENT', 'set_behavior() returns previous behavior');
+ok($merge->get_behavior() eq 'RIGHT_PRECEDENT', 'set_behavior() actually sets the behavior)');
+
+my %rp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $rp{ss}, 'right', 'Right Precedent - Scalar on Scalar' );
+is_deeply( $rp{sa}, [ 'left', 'r1', 'r2' ], 'Right Precedent - Scalar on Array' );
+is_deeply( $rp{sh}, { right=>1 }, 'Right Precedent - Scalar on Hash' );
+is_deeply( $rp{as}, 'right', 'Right Precedent - Array on Scalar' );
+is_deeply( $rp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Right Precedent - Array on Array' );
+is_deeply( $rp{ah}, { right=>1 }, 'Right Precedent - Array on Hash' );
+is_deeply( $rp{hs}, 'right', 'Right Precedent - Hash on Scalar' );
+is_deeply( $rp{ha}, [ 1, 'r1', 'r2' ], 'Right Precedent - Hash on Array' );
+is_deeply( $rp{hh}, { left=>1, right=>1 }, 'Right Precedent - Hash on Hash' );
+
+Hash::Merge::set_behavior( 'STORAGE_PRECEDENT' );
+ok($merge->get_behavior() eq 'RIGHT_PRECEDENT', '"global" function does not affect object');
+$merge->set_behavior('STORAGE_PRECEDENT');
+
+my %sp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $sp{ss}, 'left', 'Storage Precedent - Scalar on Scalar' );
+is_deeply( $sp{sa}, [ 'left', 'r1', 'r2' ], 'Storage Precedent - Scalar on Array' );
+is_deeply( $sp{sh}, { right=>1 }, 'Storage Precedent - Scalar on Hash' );
+is_deeply( $sp{as}, [ 'l1', 'l2', 'right'], 'Storage Precedent - Array on Scalar' );
+is_deeply( $sp{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Storage Precedent - Array on Array' );
+is_deeply( $sp{ah}, { right=>1 }, 'Storage Precedent - Array on Hash' );
+is_deeply( $sp{hs}, { left=>1 }, 'Storage Precedent - Hash on Scalar' );
+is_deeply( $sp{ha}, { left=>1 }, 'Storage Precedent - Hash on Array' );
+is_deeply( $sp{hh}, { left=>1, right=>1 }, 'Storage Precedent - Hash on Hash' );
+
+$merge->set_behavior('RETAINMENT_PRECEDENT');
+my %rep = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $rep{ss}, [ 'left', 'right' ], 'Retainment Precedent - Scalar on Scalar' );
+is_deeply( $rep{sa}, [ 'left', 'r1', 'r2' ], 'Retainment Precedent - Scalar on Array' );
+is_deeply( $rep{sh}, { left=>'left', right=>1 }, 'Retainment Precedent - Scalar on Hash' );
+is_deeply( $rep{as}, [ 'l1', 'l2', 'right'], 'Retainment Precedent - Array on Scalar' );
+is_deeply( $rep{aa}, [ 'l1', 'l2', 'r1', 'r2' ], 'Retainment Precedent - Array on Array' );
+is_deeply( $rep{ah}, { l1=>'l1', l2=>'l2', right=>1 },
+ 'Retainment Precedent - Array on Hash' );
+is_deeply( $rep{hs}, { left=>1, right=>'right' },
+ 'Retainment Precedent - Hash on Scalar' );
+is_deeply( $rep{ha}, { left=>1, r1=>'r1', r2=>'r2' },
+ 'Retainment Precedent - Hash on Array' );
+is_deeply( $rep{hh}, { left=>1, right=>1 }, 'Retainment Precedent - Hash on Hash' );
+
+$merge->specify_behavior( {
+ SCALAR => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } },
+ ARRAY => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } },
+ HASH => {
+ SCALAR => sub { $_[0] },
+ ARRAY => sub { $_[0] },
+ HASH => sub { $_[0] } }
+ }, "My Behavior" );
+
+my %cp = %{$merge->merge( \%left, \%right )};
+
+is_deeply( $cp{ss}, 'left', 'Custom Precedent - Scalar on Scalar' );
+is_deeply( $cp{sa}, 'left', 'Custom Precedent - Scalar on Array' );
+is_deeply( $cp{sh}, 'left', 'Custom Precedent - Scalar on Hash' );
+is_deeply( $cp{as}, [ 'l1', 'l2'], 'Custom Precedent - Array on Scalar' );
+is_deeply( $cp{aa}, [ 'l1', 'l2'], 'Custom Precedent - Array on Array' );
+is_deeply( $cp{ah}, [ 'l1', 'l2'], 'Custom Precedent - Array on Hash' );
+is_deeply( $cp{hs}, { left=>1 }, 'Custom Precedent - Hash on Scalar' );
+is_deeply( $cp{ha}, { left=>1 }, 'Custom Precedent - Hash on Array' );
+is_deeply( $cp{hh}, { left=>1 }, 'Custom Precedent - Hash on Hash' );
Propchange: branches/upstream/libhash-merge-perl/current/t/oo.t
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-perl-cvs-commits
mailing list