Initial Commit

database/perl/lib/CPAN/Meta/Merge.pm

@@ -0,0 +1,351 @@
+use strict;
+use warnings;
+
+package CPAN::Meta::Merge;
+
+our $VERSION = '2.150010';
+
+use Carp qw/croak/;
+use Scalar::Util qw/blessed/;
+use CPAN::Meta::Converter 2.141170;
+
+sub _is_identical {
+  my ($left, $right) = @_;
+  return
+    (not defined $left and not defined $right)
+    # if either of these are references, we compare the serialized value
+    || (defined $left and defined $right and $left eq $right);
+}
+
+sub _identical {
+  my ($left, $right, $path) = @_;
+  croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right
+    unless _is_identical($left, $right);
+  return $left;
+}
+
+sub _merge {
+  my ($current, $next, $mergers, $path) = @_;
+  for my $key (keys %{$next}) {
+    if (not exists $current->{$key}) {
+      $current->{$key} = $next->{$key};
+    }
+    elsif (my $merger = $mergers->{$key}) {
+      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+    }
+    elsif ($merger = $mergers->{':default'}) {
+      $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]);
+    }
+    else {
+      croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key;
+    }
+  }
+  return $current;
+}
+
+sub _uniq {
+  my %seen = ();
+  return grep { not $seen{$_}++ } @_;
+}
+
+sub _set_addition {
+  my ($left, $right) = @_;
+  return [ +_uniq(@{$left}, @{$right}) ];
+}
+
+sub _uniq_map {
+  my ($left, $right, $path) = @_;
+  for my $key (keys %{$right}) {
+    if (not exists $left->{$key}) {
+      $left->{$key} = $right->{$key};
+    }
+    # identical strings or references are merged identically
+    elsif (_is_identical($left->{$key}, $right->{$key})) {
+      1; # do nothing - keep left
+    }
+    elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') {
+      $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]);
+    }
+    else {
+      croak 'Duplication of element ' . join '.', @{$path}, $key;
+    }
+  }
+  return $left;
+}
+
+sub _improvise {
+  my ($left, $right, $path) = @_;
+  my ($name) = reverse @{$path};
+  if ($name =~ /^x_/) {
+    if (ref($left) eq 'ARRAY') {
+      return _set_addition($left, $right, $path);
+    }
+    elsif (ref($left) eq 'HASH') {
+      return _uniq_map($left, $right, $path);
+    }
+    else {
+      return _identical($left, $right, $path);
+    }
+  }
+  croak sprintf "Can't merge '%s'", join '.', @{$path};
+}
+
+sub _optional_features {
+  my ($left, $right, $path) = @_;
+
+  for my $key (keys %{$right}) {
+    if (not exists $left->{$key}) {
+      $left->{$key} = $right->{$key};
+    }
+    else {
+      for my $subkey (keys %{ $right->{$key} }) {
+        next if $subkey eq 'prereqs';
+        if (not exists $left->{$key}{$subkey}) {
+          $left->{$key}{$subkey} = $right->{$key}{$subkey};
+        }
+        else {
+          Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values"
+            if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} };
+        }
+      }
+
+      require CPAN::Meta::Prereqs;
+      $left->{$key}{prereqs} =
+        CPAN::Meta::Prereqs->new($left->{$key}{prereqs})
+          ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))
+          ->as_string_hash;
+    }
+  }
+  return $left;
+}
+
+
+my %default = (
+  abstract       => \&_identical,
+  author         => \&_set_addition,
+  dynamic_config => sub {
+    my ($left, $right) = @_;
+    return $left || $right;
+  },
+  generated_by => sub {
+    my ($left, $right) = @_;
+    return join ', ', _uniq(split(/, /, $left), split(/, /, $right));
+  },
+  license     => \&_set_addition,
+  'meta-spec' => {
+    version => \&_identical,
+    url     => \&_identical
+  },
+  name              => \&_identical,
+  release_status    => \&_identical,
+  version           => \&_identical,
+  description       => \&_identical,
+  keywords          => \&_set_addition,
+  no_index          => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ },
+  optional_features => \&_optional_features,
+  prereqs           => sub {
+    require CPAN::Meta::Prereqs;
+    my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1];
+    return $left->with_merged_prereqs($right)->as_string_hash;
+  },
+  provides  => \&_uniq_map,
+  resources => {
+    license    => \&_set_addition,
+    homepage   => \&_identical,
+    bugtracker => \&_uniq_map,
+    repository => \&_uniq_map,
+    ':default' => \&_improvise,
+  },
+  ':default' => \&_improvise,
+);
+
+sub new {
+  my ($class, %arguments) = @_;
+  croak 'default version required' if not exists $arguments{default_version};
+  my %mapping = %default;
+  my %extra = %{ $arguments{extra_mappings} || {} };
+  for my $key (keys %extra) {
+    if (ref($mapping{$key}) eq 'HASH') {
+      $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } };
+    }
+    else {
+      $mapping{$key} = $extra{$key};
+    }
+  }
+  return bless {
+    default_version => $arguments{default_version},
+    mapping => _coerce_mapping(\%mapping, []),
+  }, $class;
+}
+
+my %coderef_for = (
+  set_addition => \&_set_addition,
+  uniq_map     => \&_uniq_map,
+  identical    => \&_identical,
+  improvise    => \&_improvise,
+  improvize    => \&_improvise, # [sic] for backwards compatibility
+);
+
+sub _coerce_mapping {
+  my ($orig, $map_path) = @_;
+  my %ret;
+  for my $key (keys %{$orig}) {
+    my $value = $orig->{$key};
+    if (ref($orig->{$key}) eq 'CODE') {
+      $ret{$key} = $value;
+    }
+    elsif (ref($value) eq 'HASH') {
+      my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]);
+      $ret{$key} = sub {
+        my ($left, $right, $path) = @_;
+        return _merge($left, $right, $mapping, [ @{$path} ]);
+      };
+    }
+    elsif ($coderef_for{$value}) {
+      $ret{$key} = $coderef_for{$value};
+    }
+    else {
+      croak "Don't know what to do with " . join '.', @{$map_path}, $key;
+    }
+  }
+  return \%ret;
+}
+
+sub merge {
+  my ($self, @items) = @_;
+  my $current = {};
+  for my $next (@items) {
+    if ( blessed($next) && $next->isa('CPAN::Meta') ) {
+      $next = $next->as_struct;
+    }
+    elsif ( ref($next) eq 'HASH' ) {
+      my $cmc = CPAN::Meta::Converter->new(
+        $next, default_version => $self->{default_version}
+      );
+      $next = $cmc->upgrade_fragment;
+    }
+    else {
+      croak "Don't know how to merge '$next'";
+    }
+    $current = _merge($current, $next, $self->{mapping}, []);
+  }
+  return $current;
+}
+
+1;
+
+# ABSTRACT: Merging CPAN Meta fragments
+
+
+# vim: ts=2 sts=2 sw=2 et :
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+CPAN::Meta::Merge - Merging CPAN Meta fragments
+
+=head1 VERSION
+
+version 2.150010
+
+=head1 SYNOPSIS
+
+ my $merger = CPAN::Meta::Merge->new(default_version => "2");
+ my $meta = $merger->merge($base, @additional);
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 new
+
+This creates a CPAN::Meta::Merge object. It takes one mandatory named
+argument, C<version>, declaring the version of the meta-spec that must be
+used for the merge. It can optionally take an C<extra_mappings> argument
+that allows one to add additional merging functions for specific elements.
+
+The C<extra_mappings> arguments takes a hash ref with the same type of
+structure as described in L<CPAN::Meta::Spec>, except with its values as
+one of the L<defined merge strategies|/"MERGE STRATEGIES"> or a code ref
+to a merging function.
+
+  my $merger = CPAN::Meta::Merge->new(
+      default_version => '2',
+      extra_mappings => {
+          'optional_features' => \&custom_merge_function,
+          'x_custom' => 'set_addition',
+          'x_meta_meta' => {
+              name => 'identical',
+              tags => 'set_addition',
+          }
+      }
+  );
+
+=head2 merge(@fragments)
+
+Merge all C<@fragments> together. It will accept both CPAN::Meta objects and
+(possibly incomplete) hashrefs of metadata.
+
+=head1 MERGE STRATEGIES
+
+C<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>:
+
+=over
+
+=item identical
+
+The elements must be identical
+
+=item set_addition
+
+The union of two array refs
+
+  [ a, b ] U [ a, c]  = [ a, b, c ]
+
+=item uniq_map
+
+Key value pairs from the right hash are merged to the left hash.  Key
+collisions are only allowed if their values are the same.  This merge
+function will recurse into nested hash refs following the same merge
+rules.
+
+=item improvise
+
+This merge strategy will try to pick the appropriate predefined strategy
+based on what element type.  Array refs will try to use the
+C<set_addition> strategy,  Hash refs will try to use the C<uniq_map>
+strategy, and everything else will try the C<identical> strategy.
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item *
+
+David Golden <dagolden@cpan.org>
+
+=item *
+
+Ricardo Signes <rjbs@cpan.org>
+
+=item *
+
+Adam Kennedy <adamk@cpan.org>
+
+=back
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=cut