1use strict;
2use warnings;
3
4package CPAN::Meta::Merge;
5
6our $VERSION = '2.150010';
7
8use Carp qw/croak/;
9use Scalar::Util qw/blessed/;
10use CPAN::Meta::Converter 2.141170;
11
12sub _is_identical {
13  my ($left, $right) = @_;
14  return
15    (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
20sub _identical {
21  my ($left, $right, $path) = @_;
22  croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
23    unless _is_identical($left, $right);
24  return $left;
25}
26
27sub _merge {
28  my ($current, $next, $mergers, $path) = @_;
29  for my $key (keys %{$next}) {
30    if (not exists $current->{$key}) {
31      $current->{$key} = $next->{$key};
32    }
33    elsif (my $merger = $mergers->{$key}) {
34      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
35    }
36    elsif ($merger = $mergers->{':default'}) {
37      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
38    }
39    else {
40      croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
41    }
42  }
43  return $current;
44}
45
46sub _uniq {
47  my %seen = ();
48  return grep { not $seen{$_}++ } @_;
49}
50
51sub _set_addition {
52  my ($left, $right) = @_;
53  return [ +_uniq(@{$left}, @{$right}) ];
54}
55
56sub _uniq_map {
57  my ($left, $right, $path) = @_;
58  for my $key (keys %{$right}) {
59    if (not exists $left->{$key}) {
60      $left->{$key} = $right->{$key};
61    }
62    # identical strings or references are merged identically
63    elsif (_is_identical($left->{$key}, $right->{$key})) {
64      1; # do nothing - keep left
65    }
66    elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
67      $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
68    }
69    else {
70      croak 'Duplication of element ' . join '.', @{$path}, $key;
71    }
72  }
73  return $left;
74}
75
76sub _improvise {
77  my ($left, $right, $path) = @_;
78  my ($name) = reverse @{$path};
79  if ($name =~ /^x_/) {
80    if (ref($left) eq 'ARRAY') {
81      return _set_addition($left, $right, $path);
82    }
83    elsif (ref($left) eq 'HASH') {
84      return _uniq_map($left, $right, $path);
85    }
86    else {
87      return _identical($left, $right, $path);
88    }
89  }
90  croak sprintf "Can't merge '%s'", join '.', @{$path};
91}
92
93sub _optional_features {
94  my ($left, $right, $path) = @_;
95
96  for my $key (keys %{$right}) {
97    if (not exists $left->{$key}) {
98      $left->{$key} = $right->{$key};
99    }
100    else {
101      for my $subkey (keys %{ $right->{$key} }) {
102        next if $subkey eq 'prereqs';
103        if (not exists $left->{$key}{$subkey}) {
104          $left->{$key}{$subkey} = $right->{$key}{$subkey};
105        }
106        else {
107          Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
108            if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
109        }
110      }
111
112      require CPAN::Meta::Prereqs;
113      $left->{$key}{prereqs} =
114        CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
115          ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
116          ->as_string_hash;
117    }
118  }
119  return $left;
120}
121
122
123my %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
162sub new {
163  my ($class, %arguments) = @_;
164  croak 'default version required' if not exists $arguments{default_version};
165  my %mapping = %default;
166  my %extra = %{ $arguments{extra_mappings} || {} };
167  for my $key (keys %extra) {
168    if (ref($mapping{$key}) eq 'HASH') {
169      $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
170    }
171    else {
172      $mapping{$key} = $extra{$key};
173    }
174  }
175  return bless {
176    default_version => $arguments{default_version},
177    mapping => _coerce_mapping(\%mapping, []),
178  }, $class;
179}
180
181my %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
189sub _coerce_mapping {
190  my ($orig, $map_path) = @_;
191  my %ret;
192  for my $key (keys %{$orig}) {
193    my $value = $orig->{$key};
194    if (ref($orig->{$key}) eq 'CODE') {
195      $ret{$key} = $value;
196    }
197    elsif (ref($value) eq 'HASH') {
198      my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
199      $ret{$key} = sub {
200        my ($left, $right, $path) = @_;
201        return _merge($left, $right, $mapping, [ @{$path} ]);
202      };
203    }
204    elsif ($coderef_for{$value}) {
205      $ret{$key} = $coderef_for{$value};
206    }
207    else {
208      croak "Don't know what to do with " . join '.', @{$map_path}, $key;
209    }
210  }
211  return \%ret;
212}
213
214sub merge {
215  my ($self, @items) = @_;
216  my $current = {};
217  for my $next (@items) {
218    if ( blessed($next) && $next->isa('CPAN::Meta') ) {
219      $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      );
225      $next = $cmc->upgrade_fragment;
226    }
227    else {
228      croak "Don't know how to merge '$next'";
229    }
230    $current = _merge($current, $next, $self->{mapping}, []);
231  }
232  return $current;
233}
234
2351;
236
237# ABSTRACT: Merging CPAN Meta fragments
238
239
240# vim: ts=2 sts=2 sw=2 et :
241
242__END__
243
244=pod
245
246=encoding UTF-8
247
248=head1 NAME
249
250CPAN::Meta::Merge - Merging CPAN Meta fragments
251
252=head1 VERSION
253
254version 2.150010
255
256=head1 SYNOPSIS
257
258 my $merger = CPAN::Meta::Merge->new(default_version => "2");
259 my $meta = $merger->merge($base, @additional);
260
261=head1 DESCRIPTION
262
263=head1 METHODS
264
265=head2 new
266
267This creates a CPAN::Meta::Merge object. It takes one mandatory named
268argument, C<version>, declaring the version of the meta-spec that must be
269used for the merge. It can optionally take an C<extra_mappings> argument
270that allows one to add additional merging functions for specific elements.
271
272The C<extra_mappings> arguments takes a hash ref with the same type of
273structure as described in L<CPAN::Meta::Spec>, except with its values as
274one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
275to a merging function.
276
277  my $merger = CPAN::Meta::Merge->new(
278      default_version => '2',
279      extra_mappings => {
280          'optional_features' => \&custom_merge_function,
281          'x_custom' => 'set_addition',
282          'x_meta_meta' => {
283              name => 'identical',
284              tags => 'set_addition',
285          }
286      }
287  );
288
289=head2 merge(@fragments)
290
291Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
292(possibly incomplete) hashrefs of metadata.
293
294=head1 MERGE STRATEGIES
295
296C<merge> uses various strategies to combine different elements of the CPAN::Meta objects.  The following strategies can be used with the extra_mappings argument of C<new>:
297
298=over
299
300=item identical
301
302The elements must be identical
303
304=item set_addition
305
306The union of two array refs
307
308  [ a, b ] U [ a, c]  = [ a, b, c ]
309
310=item uniq_map
311
312Key value pairs from the right hash are merged to the left hash.  Key
313collisions are only allowed if their values are the same.  This merge
314function will recurse into nested hash refs following the same merge
315rules.
316
317=item improvise
318
319This merge strategy will try to pick the appropriate predefined strategy
320based on what element type.  Array refs will try to use the
321C<set_addition> strategy,  Hash refs will try to use the C<uniq_map>
322strategy, and everything else will try the C<identical> strategy.
323
324=back
325
326=head1 AUTHORS
327
328=over 4
329
330=item *
331
332David Golden <dagolden@cpan.org>
333
334=item *
335
336Ricardo Signes <rjbs@cpan.org>
337
338=item *
339
340Adam Kennedy <adamk@cpan.org>
341
342=back
343
344=head1 COPYRIGHT AND LICENSE
345
346This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
347
348This is free software; you can redistribute it and/or modify it under
349the same terms as the Perl 5 programming language system itself.
350
351=cut
352