File Coverage

blib/lib/CPAN/Meta/Merge.pm
Criterion Covered Total %
statement 97 118 82.2
branch 30 44 68.1
condition 5 9 55.5
subroutine 17 18 94.4
pod 2 2 100.0
total 151 191 79.0


line stmt bran cond sub pod time code
1 2     2   698 use strict;
  2         3  
  2         43  
2 2     2   5 use warnings;
  2         3  
  2         70  
3              
4             package CPAN::Meta::Merge;
5              
6             our $VERSION = '2.150010';
7              
8 2     2   6 use Carp qw/croak/;
  2         1  
  2         70  
9 2     2   53 use Scalar::Util qw/blessed/;
  2         2  
  2         72  
10 2     2   6 use CPAN::Meta::Converter 2.141170;
  2         28  
  2         986  
11              
12             sub _is_identical {
13 34     34   27 my ($left, $right) = @_;
14             return
15 34   33     260 (not defined $left and not defined $right)
16             # if either of these are references, we compare the serialized value
17             || (defined $left and defined $right and $left eq $right);
18             }
19              
20             sub _identical {
21 29     29   27 my ($left, $right, $path) = @_;
22 29 100       27 croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
  1         128  
23             unless _is_identical($left, $right);
24 28         47 return $left;
25             }
26              
27             sub _merge {
28 48     48   45 my ($current, $next, $mergers, $path) = @_;
29 48         34 for my $key (keys %{$next}) {
  48         68  
30 202 100       242 if (not exists $current->{$key}) {
    50          
    0          
31 131         128 $current->{$key} = $next->{$key};
32             }
33             elsif (my $merger = $mergers->{$key}) {
34 71         58 $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
  71         107  
35             }
36             elsif ($merger = $mergers->{':default'}) {
37 0         0 $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
  0         0  
38             }
39             else {
40 0         0 croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
  0         0  
41             }
42             }
43 41         95 return $current;
44             }
45              
46             sub _uniq {
47 10     10   9 my %seen = ();
48 10         8 return grep { not $seen{$_}++ } @_;
  20         63  
49             }
50              
51             sub _set_addition {
52 8     8   7 my ($left, $right) = @_;
53 8         6 return [ +_uniq(@{$left}, @{$right}) ];
  8         6  
  8         9  
54             }
55              
56             sub _uniq_map {
57 7     7   8 my ($left, $right, $path) = @_;
58 7         7 for my $key (keys %{$right}) {
  7         11  
59 8 100 66     14 if (not exists $left->{$key}) {
    100          
    100          
60 3         8 $left->{$key} = $right->{$key};
61             }
62             # identical strings or references are merged identically
63             elsif (_is_identical($left->{$key}, $right->{$key})) {
64 1         2 1; # do nothing - keep left
65             }
66             elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
67 2         3 $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
  2         11  
68             }
69             else {
70 2         2 croak 'Duplication of element ' . join '.', @{$path}, $key;
  2         158  
71             }
72             }
73 4         8 return $left;
74             }
75              
76             sub _improvise {
77 0     0   0 my ($left, $right, $path) = @_;
78 0         0 my ($name) = reverse @{$path};
  0         0  
79 0 0       0 if ($name =~ /^x_/) {
80 0 0       0 if (ref($left) eq 'ARRAY') {
    0          
81 0         0 return _set_addition($left, $right, $path);
82             }
83             elsif (ref($left) eq 'HASH') {
84 0         0 return _uniq_map($left, $right, $path);
85             }
86             else {
87 0         0 return _identical($left, $right, $path);
88             }
89             }
90 0         0 croak sprintf "Can't merge '%s'", join '.', @{$path};
  0         0  
91             }
92              
93             sub _optional_features {
94 4     4   5 my ($left, $right, $path) = @_;
95              
96 4         3 for my $key (keys %{$right}) {
  4         6  
97 4 100       7 if (not exists $left->{$key}) {
98 1         2 $left->{$key} = $right->{$key};
99             }
100             else {
101 3         2 for my $subkey (keys %{ $right->{$key} }) {
  3         5  
102 6 100       9 next if $subkey eq 'prereqs';
103 4 50       5 if (not exists $left->{$key}{$subkey}) {
104 0         0 $left->{$key}{$subkey} = $right->{$key}{$subkey};
105             }
106             else {
107             Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
108 2 100   2   8 if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
  2         2  
  2         1402  
  4         4  
  4         212  
109             }
110             }
111              
112 1         7 require CPAN::Meta::Prereqs;
113             $left->{$key}{prereqs} =
114             CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
115 1         6 ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
116             ->as_string_hash;
117             }
118             }
119 2         4 return $left;
120             }
121              
122              
123             my %default = (
124             abstract => \&_identical,
125             author => \&_set_addition,
126             dynamic_config => sub {
127             my ($left, $right) = @_;
128             return $left || $right;
129             },
130             generated_by => sub {
131             my ($left, $right) = @_;
132             return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
133             },
134             license => \&_set_addition,
135             'meta-spec' => {
136             version => \&_identical,
137             url => \&_identical
138             },
139             name => \&_identical,
140             release_status => \&_identical,
141             version => \&_identical,
142             description => \&_identical,
143             keywords => \&_set_addition,
144             no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
145             optional_features => \&_optional_features,
146             prereqs => sub {
147             require CPAN::Meta::Prereqs;
148             my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
149             return $left->with_merged_prereqs($right)->as_string_hash;
150             },
151             provides => \&_uniq_map,
152             resources => {
153             license => \&_set_addition,
154             homepage => \&_identical,
155             bugtracker => \&_uniq_map,
156             repository => \&_uniq_map,
157             ':default' => \&_improvise,
158             },
159             ':default' => \&_improvise,
160             );
161              
162             sub new {
163 4     4 1 2593 my ($class, %arguments) = @_;
164 4 50       17 croak 'default version required' if not exists $arguments{default_version};
165 4         29 my %mapping = %default;
166 4 100       6 my %extra = %{ $arguments{extra_mappings} || {} };
  4         19  
167 4         11 for my $key (keys %extra) {
168 3 50       7 if (ref($mapping{$key}) eq 'HASH') {
169 0         0 $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
  0         0  
  0         0  
170             }
171             else {
172 3         5 $mapping{$key} = $extra{$key};
173             }
174             }
175             return bless {
176             default_version => $arguments{default_version},
177 4         10 mapping => _coerce_mapping(\%mapping, []),
178             }, $class;
179             }
180              
181             my %coderef_for = (
182             set_addition => \&_set_addition,
183             uniq_map => \&_uniq_map,
184             identical => \&_identical,
185             improvise => \&_improvise,
186             improvize => \&_improvise, # [sic] for backwards compatibility
187             );
188              
189             sub _coerce_mapping {
190 17     17   13 my ($orig, $map_path) = @_;
191 17         12 my %ret;
192 17         12 for my $key (keys %{$orig}) {
  17         32  
193 116         70 my $value = $orig->{$key};
194 116 100       138 if (ref($orig->{$key}) eq 'CODE') {
    100          
    50          
195 100         96 $ret{$key} = $value;
196             }
197             elsif (ref($value) eq 'HASH') {
198 13         9 my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
  13         34  
199             $ret{$key} = sub {
200 17     17   15 my ($left, $right, $path) = @_;
201 17         12 return _merge($left, $right, $mapping, [ @{$path} ]);
  17         32  
202 13         39 };
203             }
204             elsif ($coderef_for{$value}) {
205 3         4 $ret{$key} = $coderef_for{$value};
206             }
207             else {
208 0         0 croak "Don't know what to do with " . join '.', @{$map_path}, $key;
  0         0  
209             }
210             }
211 17         34 return \%ret;
212             }
213              
214             sub merge {
215 15     15 1 10475 my ($self, @items) = @_;
216 15         17 my $current = {};
217 15         24 for my $next (@items) {
218 31 100 66     133 if ( blessed($next) && $next->isa('CPAN::Meta') ) {
    50          
219 1         11 $next = $next->as_struct;
220             }
221             elsif ( ref($next) eq 'HASH' ) {
222             my $cmc = CPAN::Meta::Converter->new(
223             $next, default_version => $self->{default_version}
224 30         85 );
225 30         58 $next = $cmc->upgrade_fragment;
226             }
227             else {
228 0         0 croak "Don't know how to merge '$next'";
229             }
230 31         60 $current = _merge($current, $next, $self->{mapping}, []);
231             }
232 9         43 return $current;
233             }
234              
235             1;
236              
237             # ABSTRACT: Merging CPAN Meta fragments
238              
239              
240             # vim: ts=2 sts=2 sw=2 et :
241              
242             __END__