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