File Coverage

blib/lib/Data/Context/BEM/Merge.pm
Criterion Covered Total %
statement 40 41 97.5
branch 15 16 93.7
condition n/a
subroutine 9 9 100.0
pod 1 1 100.0
total 65 67 97.0


line stmt bran cond sub pod time code
1             package Data::Context::BEM::Merge;
2              
3             # Created on: 2013-11-15 05:13:46
4             # Create by: Ivan Wills
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 2     2   26921 use Moose;
  2         507183  
  2         12  
10 2     2   12500 use namespace::autoclean;
  2         6488  
  2         19  
11 2     2   731 use version;
  2         1424  
  2         14  
12 2     2   150 use Carp;
  2         5  
  2         182  
13 2     2   12 use List::Util qw/max /;
  2         2  
  2         148  
14 2     2   13 use List::MoreUtils qw/uniq pairwise/;
  2         3  
  2         33  
15 2     2   1113 use Data::Dumper qw/Dumper/;
  2         5  
  2         105  
16 2     2   546 use English qw/ -no_match_vars /;
  2         3042  
  2         16  
17              
18             our $VERSION = version->new('0.0.6');
19              
20             sub merge {
21 10     10 1 54 my ($self, $child, $parent) = @_;
22              
23 10 100       37 if ( ! ref $child ) {
    100          
    50          
24 3         13 return $child;
25             }
26             elsif ( ref $child eq 'ARRAY' ) {
27 2         4 my $new = [];
28 2         5 my $max_child = @$child - 1;
29 2         3 my $max_parent = @$parent - 1;
30              
31 2         12 for my $i ( 0 .. max $max_child, $max_parent ) {
32 4 100       20 $new->[$i]
33             = exists $child->[$i]
34             ? $self->merge( $child->[$i], $parent->[$i] )
35             : $parent->[$i];
36             }
37              
38 2         5 return $new;
39             }
40             elsif ( ref $child eq 'HASH' ) {
41 5         6 my $new = {};
42              
43 5         63 for my $key ( uniq sort +(keys %$child), (keys %$parent) ) {
44 8 100       21 if ( $key eq 'content' ) {
45 2 100       10 $child->{$key} = [ $child->{$key} ] if ref $child->{$key} ne 'ARRAY';
46 2 100       9 $parent->{$key} = [ $parent->{$key} ] if ref $parent->{$key} ne 'ARRAY';
47             }
48              
49             $new->{$key}
50             = exists $child->{$key}
51             ? $self->merge( $child->{$key}, $parent->{$key} )
52 8 100       43 : $parent->{$key};
53             }
54              
55 5         24 return $new;
56             }
57             else {
58 0           return $child;
59             }
60             }
61              
62             __PACKAGE__->meta->make_immutable;
63              
64             1;
65              
66             __END__
67              
68             =head1 NAME
69              
70             Data::Context::BEM::Merge - Merge algorithm that merges arrays (not appending them)
71              
72             =head1 VERSION
73              
74             This documentation refers to Data::Context::BEM::Merge version 0.0.6
75              
76             =head1 SYNOPSIS
77              
78             use Data::Context::BEM::Merge;
79              
80             my $merge = Data::Context::BEM::Merge->new();
81             my $merged = $merge->merge({a => [1,2]}, {a => [2,3]});
82              
83             # $merged = { a => [2,3] }
84              
85             =head1 DESCRIPTION
86              
87             =head1 SUBROUTINES/METHODS
88              
89             =head2 C<merge ($ref1, $ref2)>
90              
91             Merges $ref2 into clone of $ref1.
92              
93             =head1 DIAGNOSTICS
94              
95             =head1 CONFIGURATION AND ENVIRONMENT
96              
97             =head1 DEPENDENCIES
98              
99             =head1 INCOMPATIBILITIES
100              
101             =head1 BUGS AND LIMITATIONS
102              
103             There are no known bugs in this module.
104              
105             Please report problems to Ivan Wills (ivan.wills@gmail.com).
106              
107             Patches are welcome.
108              
109             =head1 AUTHOR
110              
111             Ivan Wills - (ivan.wills@gmail.com)
112              
113             =head1 LICENSE AND COPYRIGHT
114              
115             Copyright (c) 2013 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW Australia 2077).
116             All rights reserved.
117              
118             This module is free software; you can redistribute it and/or modify it under
119             the same terms as Perl itself. See L<perlartistic>. This program is
120             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
121             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
122             PARTICULAR PURPOSE.
123              
124             =cut