Hash-Merge-0.302/000755 000767 000024 00000000000 13710577365 014101 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/MAINTAINER.md000644 000767 000024 00000002057 13671641112 016042 0ustar00stefanstaff000000 000000 # Maintainers Guide for Hash::Merge Hash::Merge have common tests being run for several clone backends. That's why it is a bit more complicated to setup a clone for hacking on the beast. # Get what you need At first one need to clone the project and all it's submodules: $ git clone https://github.com/perl5-utils/Hash-Merge.git # Prepare environment for configure stage Then some modules are required for Makefile.PL at author level itself: $ cpanm --with-recommends --with-suggests Test::WriteVariants # Start working The typical workflow for authoring modules with ExtUtils::MakeMaker... $ cpanm --with-recommends --with-suggests --with-develop --installdeps . $ perl Makefile.PL $ make manifest $ make test # Submitting contributions When submitting patches or proposals or ideas or whatever - you realize and agree the copyright and license conditions. Do not submit anything when you don't agree on that. # Copyright and License This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. Hash-Merge-0.302/Changes000644 000767 000024 00000006641 13710576556 015404 0ustar00stefanstaff000000 000000 Revision history for Perl extension Hash::Merge. 0.302 2020-07-30 - Prevent object-based test from failing randomly on BSDs and MacOS 0.301 2020-06-18 - fix object-based interface memory leak (RT#132627) (Thanks to mithaldu) 0.300 2018-03-09 - fix old EU::MM support (RT#123915) - rename specify_behavior and improve SYNOPSIS (RT#123785) - improve CI tests - update resources information for META.json 0.299 2017-11-20 - Fixed behavior change if Hash contains blessed hashes (Thanks to David E. Wheeler) - Extended testing with blessed objects. 0.298 2017-11-15 - Version 0.298 release 0.200_003 2017-11-07 - Documentation updated and extended. - Do not clone if not a reference. This fixes a failure when using Storable as backend. - Update dependencies and requirements. - Extended testing in order to test all the different clone() backends. 0.200_002 2017-10-16 - Rely on backend() debug helper of Clone::Choose 0.003 to help identifying issues depending on underlying clone implementation 0.200_001 2017-10-11 - Switch to Clone::Choose instead of NIH clone detector. - Fixed weird object vs. global behavior - Aligned distribution sets, perltidy, perlcritic, etc. - RT#55978 Fixed avoid the eval in _get_obj (Thanks to Larry Leszczynski) - RT#81156 Fixed behavior name bug (Thanks to Matt D. Garrett) - RT#69872 Fixed cloning does not happen bug (Thanks to John Busco) - PR#1 Fixed syntax errors in code samples (Thanks to book) 0.200 2013-11-03 - modernize toolchain - reformat changes as per CPAN::Changes::Spec - move repository to GitHub 0.12 2010-02-15 - rt 39183 fallback to Clone::PP if needed/possible (thanks to MONS) - rt 43056 OO support for more sane behavior non-trampling (thanks to MONS) - Added tests for OO behavior. - Cleaned up POD a little - perltidy 0.11 2009-04-09 - fix ||= typo, thanks GWADEJ or bringing it to my attention 0.10 2007-04-08 - DMUEY rt.cpan.org id 13390 - POD Synopsis cleanup 0.09 2007-04-03 - 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 0.08 2006-08-08 - Fixed hash reference issue (per Perl 5.8.8) in test sequence 0.07 2002-02-19 - Fixed problem with ActiveState Perl's Clone.pm implementation. - Fixed typo in POD. - Fixed formatting of code in general. 0.06 2001-11-10 - Version 0.06 release (and more CVS fixes) 0.05.02.1 2001-11-08 - Fixing CVS problems 0.05.01.2 2001-11-06 - 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 0.05 2001-11-02 - Yet another fix to Test::More requirement (=> 0.33) 0.04 2001-10-31 - Forced Test::More requirement in makefile - Fixed problems with pod documentation 0.03 2001-10-28 - CPAN Release with CVS fixes 0.02 2001-10-28 23:05:03 - CPAN release 0.01.1.1 2001/10/23 03:01:34 mneylon - Slight fixes 0.01 2001/10/23 03:00:21 mneylon - Initial Release to PerlMonks Hash-Merge-0.302/MANIFEST000644 000767 000024 00000001052 13710577365 015230 0ustar00stefanstaff000000 000000 Changes lib/Hash/Merge.pm MAINTAINER.md Makefile.PL MANIFEST This list of files MANIFEST.SKIP README.md t/Auto/00-load.t t/Auto/01-merge.t t/Auto/02-oo.t t/Clone/00-load.t t/Clone/01-merge.t t/Clone/02-oo.t t/ClonePP/00-load.t t/ClonePP/01-merge.t t/ClonePP/02-oo.t t/inline/00-load.t t/inline/01-merge.t t/inline/02-oo.t t/Storable/00-load.t t/Storable/01-merge.t t/Storable/02-oo.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Hash-Merge-0.302/t/000755 000767 000024 00000000000 13710577364 014343 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/README.md000644 000767 000024 00000020431 13701372112 015337 0ustar00stefanstaff000000 000000 # NAME Hash::Merge - Merges arbitrarily deep hashes into a single hash # SYNOPSIS 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. # 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. **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 `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): - 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'); - 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'); - 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'); - 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'); Specific descriptions of how these work are detailed below. - merge ( <hashref>, <hashref> ) Merges two hashes given the rules specified. Returns a reference to the new hash. - \_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 }. - \_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 `merge`. - 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). - get\_clone\_behavior( ) Returns the current behavior for data cloning. - set\_behavior( <scalar> ) Specify which built-in behavior for merging that is desired. The scalar must be one of those given below. - get\_behavior( ) Returns the behavior that is currently in use by Hash::Merge. - 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. # 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. # AUTHOR Michael K. Neylon , Daniel Muey , Jens Rehsack , Stefan Hermes # COPYRIGHT Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved. Copyright (c) 2013-2020 Jens Rehsack. All rights reserved. Copyright (c) 2017-2020 Stefan Hermes. All rights reserved. This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. Hash-Merge-0.302/MANIFEST.SKIP000644 000767 000024 00000000532 13701372112 015756 0ustar00stefanstaff000000 000000 \B\.svn\b \B\.git\b \.gitignore$ \.[Bb][Aa][Kk]$ \.orig$ \.old$ \.tdy$ \.tmp$ \..*swp ^Makefile$ ^Build$ ^Build\.bat$ \.Inline/.* _Inline/.* \.bak$ \.tar$ \.tgz$ \.tar\.gz$ ^mess/ ^tmp/ ^testdata/ ^blib/ ^sandbox/ ^pm_to_blib$ ^cover_db/ ^_build/.* ~$ .*\.planner \.perltidyrc \.travis.yml Hash-Merge-.* \bxt Sandbox MYMETA\.json\.lock ^MYMETA\. Hash-Merge-0.302/META.yml000644 000767 000024 00000001717 13710577364 015357 0ustar00stefanstaff000000 000000 --- abstract: 'Merges arbitrarily deep hashes into a single hash' author: - 'Michael K. Neylon ' - 'Daniel Muey ' - 'Jens Rehsack ' - 'Stefan Hermes ' build_requires: Test::More: '0.9' configure_requires: ExtUtils::MakeMaker: '6.64' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Hash-Merge no_index: directory: - t - inc requires: Clone::Choose: '0.008' Scalar::Util: '0' perl: v5.8.1 resources: bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Hash-Merge homepage: https://metacpan.org/release/Hash-Merge license: http://dev.perl.org/licenses/ repository: https://github.com/perl5-utils/Hash-Merge.git version: '0.302' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Hash-Merge-0.302/lib/000755 000767 000024 00000000000 13710577364 014646 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/Makefile.PL000644 000767 000024 00000013335 13671641112 016044 0ustar00stefanstaff000000 000000 use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %RUN_DEPS = ( 'Clone::Choose' => 0.008, 'Scalar::Util' => 0, ); my %CONFIGURE_DEPS = ( 'ExtUtils::MakeMaker' => '6.64', ); my %BUILD_DEPS = (); my %TEST_DEPS = ( 'Test::More' => 0.90, ); if (-d 'Sandbox') { unless (grep { $_ eq '.' } @INC) { use lib '.'; } eval "use Sandbox::Tumble ();"; $@ and die $@; eval "use File::Path ();"; File::Path->import; -d 't/Auto' and rmtree('t/Auto'); -d 't/Clone' and rmtree('t/Clone'); -d 't/Storable' and rmtree('t/Storable'); -d 't/ClonePP' and rmtree('t/ClonePP'); Sandbox::Tumble->tumble(qw(t)); } WriteMakefile1( MIN_PERL_VERSION => '5.008001', META_MERGE => { 'meta-spec' => {version => 2}, dynamic_config => 1, resources => { repository => 'https://github.com/perl5-utils/Hash-Merge', license => 'http://dev.perl.org/licenses/', }, resources => { homepage => 'https://metacpan.org/release/Hash-Merge', repository => { url => 'https://github.com/perl5-utils/Hash-Merge.git', web => 'https://github.com/perl5-utils/Hash-Merge', type => 'git', }, bugtracker => { web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=Hash-Merge', mailto => 'hash-merge@rt.cpan.org', }, license => 'http://dev.perl.org/licenses/', }, prereqs => { develop => { requires => { 'Test::CPAN::Changes' => 0, 'Test::CheckManifest' => 0, 'Module::CPANTS::Analyse' => '0.96', 'Test::Kwalitee' => 0, 'Test::Pod' => 0, 'Test::Pod::Coverage' => 0, 'Test::Pod::Spelling::CommonMistakes' => 0, 'Test::Spelling' => 0, 'Test::Perl::Critic' => 0, 'Test::PerlTidy' => 0, 'Test::WriteVariants' => '0.014', }, }, configure => { requires => {%CONFIGURE_DEPS}, }, build => { requires => {%BUILD_DEPS}, }, test => { requires => {%TEST_DEPS}, suggests => { 'Clone' => 0.10, 'Clone::PP' => 0, 'Storable' => 0 } }, runtime => { requires => { %RUN_DEPS, perl => '5.8.1', }, }, }, }, NAME => 'Hash::Merge', VERSION_FROM => 'lib/Hash/Merge.pm', ABSTRACT_FROM => 'lib/Hash/Merge.pm', LICENSE => 'perl', AUTHOR => [ q{Michael K. Neylon }, q{Daniel Muey }, q{Jens Rehsack }, q{Stefan Hermes }, ], PREREQ_PM => \%RUN_DEPS, CONFIGURE_REQUIRES => \%CONFIGURE_DEPS, BUILD_REQUIRES => \%BUILD_DEPS, TEST_REQUIRES => \%TEST_DEPS, test => {TESTS => join(' ', 't/*.t', 'xt/*.t', 't/Auto/*.t', 't/Clone/*.t', 't/Storable/*.t', 't/ClonePP/*.t')}, (-d 'Sandbox' ? (realclean => {FILES => join(' ', 't/Auto', 't/Clone', 't/Storable', 't/ClonePP', 'M*.bak')}) : ()), ); sub WriteMakefile1 { # originally written by Alexandr Ciornii, version 0.21. Added by eumm-upgrade. my %params = @_; my $eumm_version = $ExtUtils::MakeMaker::VERSION; $eumm_version = eval $eumm_version; die "EXTRA_META is deprecated" if (exists($params{EXTRA_META})); die "License not specified" if (!exists($params{LICENSE})); $params{TEST_REQUIRES} and $eumm_version < 6.6303 and $params{BUILD_REQUIRES} = {%{$params{BUILD_REQUIRES} || {}}, %{delete $params{TEST_REQUIRES}}}; #EUMM 6.5502 has problems with BUILD_REQUIRES $params{BUILD_REQUIRES} and $eumm_version < 6.5503 and $params{PREREQ_PM} = {%{$params{PREREQ_PM} || {}}, %{delete $params{BUILD_REQUIRES}}}; ref $params{AUTHOR} and "ARRAY" eq ref $params{AUTHOR} and $eumm_version < 6.5702 and $params{AUTHOR} = join(", ", @{$params{AUTHOR}}); delete $params{CONFIGURE_REQUIRES} if ($eumm_version < 6.52); delete $params{MIN_PERL_VERSION} if ($eumm_version < 6.48); delete $params{META_MERGE} if ($eumm_version < 6.46); delete $params{META_ADD}{prereqs} if ($eumm_version < 6.58); delete $params{META_ADD}{'meta-spec'} if ($eumm_version < 6.58); delete $params{META_ADD} if ($eumm_version < 6.46); delete $params{LICENSE} if ($eumm_version < 6.31); delete $params{AUTHOR} if ($] < 5.005); delete $params{ABSTRACT_FROM} if ($] < 5.005); delete $params{BINARY_LOCATION} if ($] < 5.005); # more or less taken from Moose' Makefile.PL if ($params{CONFLICTS}) { my $ok = CheckConflicts(%params); exit(0) if ($params{PREREQ_FATAL} and not $ok); my $cpan_smoker = grep { $_ =~ m/(?:CR_SMOKER|CPAN_REPORTER|AUTOMATED_TESTING)/ } keys %ENV; unless ($cpan_smoker || $ENV{PERL_MM_USE_DEFAULT} || $ENV{SQL_STATEMENT_WARN_UPDATE}) { sleep 4 unless ($ok); } delete $params{CONFLICTS}; } WriteMakefile(%params); } Hash-Merge-0.302/META.json000644 000767 000024 00000004442 13710577365 015526 0ustar00stefanstaff000000 000000 { "abstract" : "Merges arbitrarily deep hashes into a single hash", "author" : [ "Michael K. Neylon ", "Daniel Muey ", "Jens Rehsack ", "Stefan Hermes " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Hash-Merge", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64" } }, "develop" : { "requires" : { "Module::CPANTS::Analyse" : "0.96", "Test::CPAN::Changes" : "0", "Test::CheckManifest" : "0", "Test::Kwalitee" : "0", "Test::Perl::Critic" : "0", "Test::PerlTidy" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Pod::Spelling::CommonMistakes" : "0", "Test::Spelling" : "0", "Test::WriteVariants" : "0.014" } }, "runtime" : { "requires" : { "Clone::Choose" : "0.008", "Scalar::Util" : "0", "perl" : "v5.8.1" } }, "test" : { "requires" : { "Test::More" : "0.9" }, "suggests" : { "Clone" : "0.1", "Clone::PP" : "0", "Storable" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "hash-merge@rt.cpan.org", "web" : "http://rt.cpan.org/Public/Dist/Display.html?Name=Hash-Merge" }, "homepage" : "https://metacpan.org/release/Hash-Merge", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/perl5-utils/Hash-Merge.git", "web" : "https://github.com/perl5-utils/Hash-Merge" } }, "version" : "0.302", "x_serialization_backend" : "JSON::PP version 4.02" } Hash-Merge-0.302/lib/Hash/000755 000767 000024 00000000000 13710577364 015531 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/lib/Hash/Merge.pm000755 000767 000024 00000043107 13710576315 017131 0ustar00stefanstaff000000 000000 package Hash::Merge; use strict; use warnings; use Carp; use Clone::Choose 0.008; use Scalar::Util qw(blessed weaken); use base 'Exporter'; our $CONTEXT; our $VERSION = '0.302'; our @EXPORT_OK = qw( merge _hashify _merge_hashes ); our %EXPORT_TAGS = ('custom' => [qw( _hashify _merge_hashes )]); sub _init { my $self = shift; my $weak = $self; weaken $weak; defined $self->{behaviors} or $self->{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 { $weak->_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 { $weak->_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 { $weak->_merge_hashes($_[0], $_[1]) }, }, }, 'RETAINMENT_PRECEDENT' => { 'SCALAR' => { 'SCALAR' => sub { [$_[0], $_[1]] }, 'ARRAY' => sub { [$_[0], @{$_[1]}] }, 'HASH' => sub { $weak->_merge_hashes($weak->_hashify($_[0]), $_[1]) }, }, 'ARRAY' => { 'SCALAR' => sub { [@{$_[0]}, $_[1]] }, 'ARRAY' => sub { [@{$_[0]}, @{$_[1]}] }, 'HASH' => sub { $weak->_merge_hashes($weak->_hashify($_[0]), $_[1]) }, }, 'HASH' => { 'SCALAR' => sub { $weak->_merge_hashes($_[0], $weak->_hashify($_[1])) }, 'ARRAY' => sub { $weak->_merge_hashes($_[0], $weak->_hashify($_[1])) }, 'HASH' => sub { $weak->_merge_hashes($_[0], $_[1]) }, }, }, }; defined $self->{behavior} or $self->{behavior} = 'LEFT_PRECEDENT'; croak "Behavior '$self->{behavior}' does not exist" if !exists $self->{behaviors}{$self->{behavior}}; $self->{matrix} = $self->{behaviors}{$self->{behavior}}; $self->{clone} = 1; } sub new { my ($pkg, $beh) = @_; $pkg = ref $pkg || $pkg; my $instance = bless {($beh ? (behavior => $beh) : ())}, $pkg; $instance->_init; return $instance; } sub set_behavior { my $self = &_get_obj; # '&' + no args modifies current @_ my $value = shift; my @behaviors = grep { /^$value$/i } keys %{$self->{'behaviors'}}; if (scalar @behaviors == 0) { carp 'Behavior must be one of : ' . join(', ', keys %{$self->{'behaviors'}}); return; } if (scalar @behaviors > 1) { croak 'Behavior must be unique in uppercase letters! You specified: ' . join ', ', @behaviors; } if (scalar @behaviors == 1) { $value = $behaviors[0]; } my $oldvalue = $self->{'behavior'}; $self->{'behavior'} = $value; $self->{'matrix'} = $self->{'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 add_behavior_spec { 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; } no strict "refs"; *specify_behavior = \&add_behavior_spec; use strict; sub get_behavior_spec { my $self = &_get_obj; # '&' + no args modifies current @_ my ($name) = @_; $name ||= 'user defined'; exists $self->{'behaviors'}{$name} and return $self->{'behaviors'}{$name}; return: } 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); $lefttype = "SCALAR" unless defined $lefttype and defined $self->{'matrix'}->{$lefttype}; my $righttype = ref($right); $righttype = "SCALAR" unless defined $righttype and defined $self->{'matrix'}->{$righttype}; if ($self->{'clone'}) { $left = ref($left) ? clone($left) : $left; $right = ref($right) ? clone($right) : $right; } 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 $key (keys %$left) { $newhash{$key} = exists $right->{$key} ? $self->merge($left->{$key}, $right->{$key}) : $left->{$key}; } foreach my $key (grep { !exists $left->{$_} } keys %$right) { $newhash{$key} = $right->{$key}; } 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; } my $_global; sub _get_obj { if (my $type = ref $_[0]) { return shift() if $type eq __PACKAGE__ || (blessed $_[0] && $_[0]->isa(__PACKAGE__)); } defined $CONTEXT and return $CONTEXT; defined $_global or $_global = Hash::Merge->new; return $_global; } 1; __END__ =head1 NAME Hash::Merge - Merges arbitrarily deep hashes into a single hash =begin html Travis CI Coverage Status =end html =head1 SYNOPSIS 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::add_behavior_spec( { '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 $merger = Hash::Merge->new('LEFT_PRECEDENT'); my %c = %{ $merger->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. # re-use globally specified behavior my $merger = Hash::Merge->new(); $merger->add_behavior_spec(Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior"); my %c = %{ $merger->merge( \%a, \%b ) }; # re-use externally specified behavior use Hash::Merge::Extra (); my $merger = Hash::Merge->new(); $merger->add_behavior_spec(Hash::Merge::Extra::L_REPLACE, "L_REPLACE"); my %c = %{ $merger->merge( \%a, \%b ) }; =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 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). 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_behavior('LEFT_PRECEDENT'); Hash::Merge::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_behavior('RIGHT_PRECEDENT'); Hash::Merge::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_behavior('STORAGE_PRECEDENT'); Hash::Merge::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_behavior('RETAINMENT_PRECEDENT'); Hash::Merge::set_behavior('RETAINMENT_PRECEDENT'); =back Specific descriptions of how these work are detailed below. =over =item merge ( , ) Merges two hashes given the rules specified. Returns a reference to the new hash. =item _hashify( | ) -- 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( , ) -- INTERNAL FUNCTION Actually does the key-by-key evaluation of two hashes and returns the new merged hash. Note that this recursively calls C. =item set_clone_behavior( ) 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( ) 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( , [] ) [deprecated] Alias for C. =item add_behavior_spec( , [] ) Add a custom merge behavior spec 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. =item get_behavior_spec( [] ) Return a previously defined merge behavior spec. If name ism't specified, the same default as add_behavior_spec is applied. If no such name is known referring to an behavior spec, nothing is returned. =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 AUTHOR Michael K. Neylon Emneylon-pm@masemware.comE, Daniel Muey Edmuey@cpan.orgE, Jens Rehsack Erehsack@cpan.orgE, Stefan Hermes Ehermes@cpan.orgE =head1 COPYRIGHT Copyright (c) 2001,2002 Michael K. Neylon. All rights reserved. Copyright (c) 2013-2020 Jens Rehsack. All rights reserved. Copyright (c) 2017-2020 Stefan Hermes. All rights reserved. This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut Hash-Merge-0.302/t/Auto/000755 000767 000024 00000000000 13710577364 015253 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/t/Storable/000755 000767 000024 00000000000 13710577364 016116 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/t/ClonePP/000755 000767 000024 00000000000 13710577364 015643 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/t/inline/000755 000767 000024 00000000000 13710577364 015621 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/t/Clone/000755 000767 000024 00000000000 13710577364 015403 5ustar00stefanstaff000000 000000 Hash-Merge-0.302/t/Clone/02-oo.t000644 000767 000024 00000025204 13710577347 016430 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge; my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); $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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); $merge->add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge->new->merge($h1, $h2); main::ok($merged); } { my $destroyed = 0; no warnings 'once'; local *Hash::Merge::DESTROY = sub { $destroyed = 1; }; use warnings; Hash::Merge->new; sleep 1; ok $destroyed, "instance did not leak"; } done_testing; Hash-Merge-0.302/t/Clone/01-merge.t000644 000767 000024 00000024045 13710577347 017113 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge qw( merge ); my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); 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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); Hash::Merge::add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge::merge($h1, $h2); main::ok($merged); } done_testing; Hash-Merge-0.302/t/Clone/00-load.t000644 000767 000024 00000001226 13710577347 016726 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; use_ok('Hash::Merge') || BAIL_OUT("Couldn't load Hash::Merge"); } diag("Testing Hash::Merge version $Hash::Merge::VERSION, Perl $], $^X"); my $backend = Clone::Choose->backend; diag( "Using backend $backend version " . $backend->VERSION ); done_testing; Hash-Merge-0.302/t/inline/02-oo.t000644 000767 000024 00000024706 13710545610 016640 0ustar00stefanstaff000000 000000 use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge; my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); $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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); $merge->add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge->new->merge($h1, $h2); main::ok($merged); } { my $destroyed = 0; no warnings 'once'; local *Hash::Merge::DESTROY = sub { $destroyed = 1; }; use warnings; Hash::Merge->new; sleep 1; ok $destroyed, "instance did not leak"; } done_testing; Hash-Merge-0.302/t/inline/01-merge.t000644 000767 000024 00000023547 13671641112 017323 0ustar00stefanstaff000000 000000 use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge qw( merge ); my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); 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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); Hash::Merge::add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge::merge($h1, $h2); main::ok($merged); } done_testing; Hash-Merge-0.302/t/inline/00-load.t000644 000767 000024 00000000730 13671641112 017127 0ustar00stefanstaff000000 000000 use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; use_ok('Hash::Merge') || BAIL_OUT("Couldn't load Hash::Merge"); } diag("Testing Hash::Merge version $Hash::Merge::VERSION, Perl $], $^X"); my $backend = Clone::Choose->backend; diag( "Using backend $backend version " . $backend->VERSION ); done_testing; Hash-Merge-0.302/t/ClonePP/02-oo.t000644 000767 000024 00000025210 13710577347 016665 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone::PP"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge; my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); $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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); $merge->add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge->new->merge($h1, $h2); main::ok($merged); } { my $destroyed = 0; no warnings 'once'; local *Hash::Merge::DESTROY = sub { $destroyed = 1; }; use warnings; Hash::Merge->new; sleep 1; ok $destroyed, "instance did not leak"; } done_testing; Hash-Merge-0.302/t/ClonePP/01-merge.t000644 000767 000024 00000024051 13710577347 017350 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone::PP"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge qw( merge ); my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); 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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); Hash::Merge::add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge::merge($h1, $h2); main::ok($merged); } done_testing; Hash-Merge-0.302/t/ClonePP/00-load.t000644 000767 000024 00000001232 13710577347 017163 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Clone::PP"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; use_ok('Hash::Merge') || BAIL_OUT("Couldn't load Hash::Merge"); } diag("Testing Hash::Merge version $Hash::Merge::VERSION, Perl $], $^X"); my $backend = Clone::Choose->backend; diag( "Using backend $backend version " . $backend->VERSION ); done_testing; Hash-Merge-0.302/t/Storable/02-oo.t000644 000767 000024 00000025207 13710577347 017146 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Storable"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge; my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); $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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); $merge->add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge->new->merge($h1, $h2); main::ok($merged); } { my $destroyed = 0; no warnings 'once'; local *Hash::Merge::DESTROY = sub { $destroyed = 1; }; use warnings; Hash::Merge->new; sleep 1; ok $destroyed, "instance did not leak"; } done_testing; Hash-Merge-0.302/t/Storable/01-merge.t000644 000767 000024 00000024050 13710577347 017622 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Storable"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge qw( merge ); my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); 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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); Hash::Merge::add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge::merge($h1, $h2); main::ok($merged); } done_testing; Hash-Merge-0.302/t/Storable/00-load.t000644 000767 000024 00000001231 13710577347 017435 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} = "Storable"; } END { delete $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} } # for VMS use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; use_ok('Hash::Merge') || BAIL_OUT("Couldn't load Hash::Merge"); } diag("Testing Hash::Merge version $Hash::Merge::VERSION, Perl $], $^X"); my $backend = Clone::Choose->backend; diag( "Using backend $backend version " . $backend->VERSION ); done_testing; Hash-Merge-0.302/t/Auto/02-oo.t000644 000767 000024 00000025014 13710577347 016277 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge; my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); $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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); $merge->add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { $merge->specify_behavior( $merge->get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge->new->merge($h1, $h2); main::ok($merged); } { my $destroyed = 0; no warnings 'once'; local *Hash::Merge::DESTROY = sub { $destroyed = 1; }; use warnings; Hash::Merge->new; sleep 1; ok $destroyed, "instance did not leak"; } done_testing; Hash-Merge-0.302/t/Auto/01-merge.t000644 000767 000024 00000023655 13710577347 016771 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; } use Hash::Merge qw( merge ); my %left = ( ss => 'left', sa => 'left', sh => 'left', so => 'left', as => ['l1', 'l2'], aa => ['l1', 'l2'], ah => ['l1', 'l2'], ao => ['l1', 'l2'], hs => {left => 1}, ha => {left => 1}, hh => {left => 1}, ho => {left => 1}, os => {foo => bless({key => 'left'}, __PACKAGE__)}, oa => {foo => bless({key => 'left'}, __PACKAGE__)}, oh => {foo => bless({key => 'left'}, __PACKAGE__)}, oo => {foo => bless({key => 'left'}, __PACKAGE__)}, ); my %right = ( ss => 'right', as => 'right', hs => 'right', os => 'right', sa => ['r1', 'r2'], aa => ['r1', 'r2'], ha => ['r1', 'r2'], oa => ['r1', 'r2'], sh => {right => 1}, ah => {right => 1}, hh => {right => 1}, oh => {right => 1}, so => {foo => bless({key => 'right'}, __PACKAGE__)}, ao => {foo => bless({key => 'right'}, __PACKAGE__)}, ho => {foo => bless({key => 'right'}, __PACKAGE__)}, oo => {foo => bless({key => 'right'}, __PACKAGE__)}, ); # 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{so}, 'left', 'Left Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2', {key => 'right'}], 'Left Precedent - Array on Object'); 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' ); is_deeply( $lp{ho}, { left => 1, foo => { key => 'right', }, }, 'Left Precedent - Hash on Object' ); is_deeply($lp{os}, {foo => {key => 'left'}}, 'Left Precedent - Object on Scalar'); is_deeply($lp{oa}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); is_deeply( $lp{oh}, { foo => {key => 'left'}, right => 1, }, 'Left Precedent - Object on Array' ); is_deeply($lp{oo}, {foo => {key => 'left'}}, 'Left Precedent - Object on Array'); 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{so}, {foo => {key => 'right'}}, 'Right Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Right Precedent - Array on Object'); 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' ); is_deeply( $rp{ho}, { foo => {key => 'right'}, left => 1, }, 'Right Precedent - Hash on Object' ); is_deeply($rp{os}, 'right', 'Right Precedent - Object on Scalar'); is_deeply($rp{oa}, [{key => 'left'}, 'r1', 'r2'], 'Right Precedent - Object on Array'); is_deeply( $rp{oh}, { foo => {key => 'left'}, right => 1, }, 'Right Precedent - Object on Hash' ); is_deeply($rp{oo}, {foo => {key => 'right'}}, 'Right Precedent - Object on Object'); 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{so}, {foo => {key => 'right'}}, 'Storage Precedent - Scalar on Object'); 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{ao}, {foo => {key => 'right'}}, 'Storage Precedent - Array on Object'); 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' ); is_deeply( $sp{ho}, { foo => {key => 'right'}, left => 1, }, 'Storage Precedent - Hash on Object' ); is_deeply($sp{os}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Scalar'); is_deeply($sp{oa}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Array'); is_deeply( $sp{oh}, { foo => {key => 'left'}, right => 1, }, 'Storage Precedent - Object on Hash' ); is_deeply($sp{oo}, {foo => {key => 'left'}}, 'Storage Precedent - Object on Object'); 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{so}, { foo => {key => 'right'}, left => 'left', }, 'Retainment Precedent - Scalar on Object' ); 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{ao}, { foo => {key => 'right'}, l1 => 'l1', l2 => 'l2', }, 'Retainment Precedent - Array on Object' ); 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' ); is_deeply( $rep{ho}, { foo => {key => 'right'}, left => 1, }, 'Retainment Precedent - Hash on Object' ); is_deeply( $rep{os}, { foo => {key => 'left'}, right => 'right', }, 'Retainment Precedent - Object on Scalar' ); is_deeply( $rep{oa}, { foo => {key => 'left'}, r1 => 'r1', r2 => 'r2', }, 'Retainment Precedent - Object on Array' ); is_deeply( $rep{oh}, { foo => {key => 'left'}, right => 1, }, 'Retainment Precedent - Object on Hash' ); is_deeply($rep{oo}, {foo => [{key => 'left'}, {key => 'right'},]}, 'Retainment Precedent - Object on Object'); Hash::Merge::add_behavior_spec( { 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" ); SCOPE: { my $err; local $SIG{__WARN__} = sub { $err = shift }; eval { Hash::Merge::specify_behavior( Hash::Merge::get_behavior_spec("My Behavior"), "My Behavior" ) }; $@ and $err = $@; like($err, qr/already defined. Please take another name/, "Cannot add behavior spec twice"); } 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{so}, 'left', 'Custom Precedent - Scalar on Object'); 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{ao}, ['l1', 'l2'], 'Custom Precedent - Array on Object'); 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'); is_deeply($cp{ho}, {left => 1}, 'Custom Precedent - Hash on Hash'); is_deeply($cp{os}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Scalar'); is_deeply($cp{oa}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Array'); is_deeply($cp{oh}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Hash'); is_deeply($cp{oo}, {foo => {key => 'left'}}, 'Custom Precedent - Object on Object'); { package # Test sponsored by David Wheeler HashMergeHashContainer; my $h1 = { foo => bless {one => 2}, __PACKAGE__ }; my $h2 = { foo => bless {one => 2}, __PACKAGE__ }; my $merged = Hash::Merge::merge($h1, $h2); main::ok($merged); } done_testing; Hash-Merge-0.302/t/Auto/00-load.t000644 000767 000024 00000001036 13710577347 016575 0ustar00stefanstaff000000 000000 #!perl use strict ("subs", "vars", "refs"); use warnings ("all"); use Test::More; BEGIN { $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} and eval "use $ENV{CLONE_CHOOSE_PREFERRED_BACKEND}; 1;"; $@ and plan skip_all => "No $ENV{CLONE_CHOOSE_PREFERRED_BACKEND} found."; use_ok('Hash::Merge') || BAIL_OUT("Couldn't load Hash::Merge"); } diag("Testing Hash::Merge version $Hash::Merge::VERSION, Perl $], $^X"); my $backend = Clone::Choose->backend; diag( "Using backend $backend version " . $backend->VERSION ); done_testing;