Current File : //usr/local/share/perl5/CPAN/Meta/Converter.pm
use 5.006;
use strict;
use warnings;
package CPAN::Meta::Converter;
# VERSION
$CPAN::Meta::Converter::VERSION = '2.143240';
#pod =head1 SYNOPSIS
#pod
#pod my $struct = decode_json_file('META.json');
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod my $new_struct = $cmc->convert( version => "2" );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module converts CPAN Meta structures from one form to another. The
#pod primary use is to convert older structures to the most modern version of
#pod the specification, but other transformations may be implemented in the
#pod future as needed. (E.g. stripping all custom fields or stripping all
#pod optional fields.)
#pod
#pod =cut
use CPAN::Meta::Validator;
use CPAN::Meta::Requirements;
use Parse::CPAN::Meta 1.4400 ();
# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls
# before 5.10, we fall back to the EUMM bundled compatibility version module if
# that's the only thing available. This shouldn't ever happen in a normal CPAN
# install of CPAN::Meta::Requirements, as version.pm will be picked up from
# prereqs and be available at runtime.
BEGIN {
eval "use version ()"; ## no critic
if ( my $err = $@ ) {
eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
}
}
# Perl 5.10.0 didn't have "is_qv" in version.pm
*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} };
sub _dclone {
my $ref = shift;
# if an object is in the data structure and doesn't specify how to
# turn itself into JSON, we just stringify the object. That does the
# right thing for typical things that might be there, like version objects,
# Path::Class objects, etc.
no warnings 'once';
no warnings 'redefine';
local *UNIVERSAL::TO_JSON = sub { "$_[0]" };
my $json = Parse::CPAN::Meta->json_backend()->new
->utf8
->allow_blessed
->convert_blessed;
$json->decode($json->encode($ref))
}
my %known_specs = (
'2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
);
my @spec_list = sort { $a <=> $b } keys %known_specs;
my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
#--------------------------------------------------------------------------#
# converters
#
# called as $converter->($element, $field_name, $full_meta, $to_version)
#
# defined return value used for field
# undef return value means field is skipped
#--------------------------------------------------------------------------#
sub _keep { $_[0] }
sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
sub _generated_by {
my $gen = shift;
my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
return $sig unless defined $gen and length $gen;
return $gen if $gen =~ /\Q$sig/;
return "$gen, $sig";
}
sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
sub _prefix_custom {
my $key = shift;
$key =~ s/^(?!x_) # Unless it already starts with x_
(?:x-?)? # Remove leading x- or x (if present)
/x_/ix; # and prepend x_
return $key;
}
sub _ucfirst_custom {
my $key = shift;
$key = ucfirst $key unless $key =~ /[A-Z]/;
return $key;
}
sub _no_prefix_ucfirst_custom {
my $key = shift;
$key =~ s/^x_//;
return _ucfirst_custom($key);
}
sub _change_meta_spec {
my ($element, undef, undef, $version) = @_;
return {
version => $version,
url => $known_specs{$version},
};
}
my @open_source = (
'perl',
'gpl',
'apache',
'artistic',
'artistic_2',
'lgpl',
'bsd',
'gpl',
'mit',
'mozilla',
'open_source',
);
my %is_open_source = map {; $_ => 1 } @open_source;
my @valid_licenses_1 = (
@open_source,
'unrestricted',
'restrictive',
'unknown',
);
my %license_map_1 = (
( map { $_ => $_ } @valid_licenses_1 ),
artistic2 => 'artistic_2',
);
sub _license_1 {
my ($element) = @_;
return 'unknown' unless defined $element;
if ( $license_map_1{lc $element} ) {
return $license_map_1{lc $element};
}
else {
return 'unknown';
}
}
my @valid_licenses_2 = qw(
agpl_3
apache_1_1
apache_2_0
artistic_1
artistic_2
bsd
freebsd
gfdl_1_2
gfdl_1_3
gpl_1
gpl_2
gpl_3
lgpl_2_1
lgpl_3_0
mit
mozilla_1_0
mozilla_1_1
openssl
perl_5
qpl_1_0
ssleay
sun
zlib
open_source
restricted
unrestricted
unknown
);
# The "old" values were defined by Module::Build, and were often vague. I have
# made the decisions below based on reading Module::Build::API and how clearly
# it specifies the version of the license.
my %license_map_2 = (
(map { $_ => $_ } @valid_licenses_2),
apache => 'apache_2_0', # clearly stated as 2.0
artistic => 'artistic_1', # clearly stated as 1
artistic2 => 'artistic_2', # clearly stated as 2
gpl => 'open_source', # we don't know which GPL; punt
lgpl => 'open_source', # we don't know which LGPL; punt
mozilla => 'open_source', # we don't know which MPL; punt
perl => 'perl_5', # clearly Perl 5
restrictive => 'restricted',
);
sub _license_2 {
my ($element) = @_;
return [ 'unknown' ] unless defined $element;
$element = [ $element ] unless ref $element eq 'ARRAY';
my @new_list;
for my $lic ( @$element ) {
next unless defined $lic;
if ( my $new = $license_map_2{lc $lic} ) {
push @new_list, $new;
}
}
return @new_list ? \@new_list : [ 'unknown' ];
}
my %license_downgrade_map = qw(
agpl_3 open_source
apache_1_1 apache
apache_2_0 apache
artistic_1 artistic
artistic_2 artistic_2
bsd bsd
freebsd open_source
gfdl_1_2 open_source
gfdl_1_3 open_source
gpl_1 gpl
gpl_2 gpl
gpl_3 gpl
lgpl_2_1 lgpl
lgpl_3_0 lgpl
mit mit
mozilla_1_0 mozilla
mozilla_1_1 mozilla
openssl open_source
perl_5 perl
qpl_1_0 open_source
ssleay open_source
sun open_source
zlib open_source
open_source open_source
restricted restrictive
unrestricted unrestricted
unknown unknown
);
sub _downgrade_license {
my ($element) = @_;
if ( ! defined $element ) {
return "unknown";
}
elsif( ref $element eq 'ARRAY' ) {
if ( @$element > 1) {
if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
return 'unknown';
}
else {
return 'open_source';
}
}
elsif ( @$element == 1 ) {
return $license_downgrade_map{lc $element->[0]} || "unknown";
}
}
elsif ( ! ref $element ) {
return $license_downgrade_map{lc $element} || "unknown";
}
return "unknown";
}
my $no_index_spec_1_2 = {
'file' => \&_listify,
'dir' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_1_3 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
};
my $no_index_spec_2 = {
'file' => \&_listify,
'directory' => \&_listify,
'package' => \&_listify,
'namespace' => \&_listify,
':custom' => \&_prefix_custom,
};
sub _no_index_1_2 {
my (undef, undef, $meta) = @_;
my $no_index = $meta->{no_index} || $meta->{private};
return unless $no_index;
# cleanup wrong format
if ( ! ref $no_index ) {
my $item = $no_index;
$no_index = { dir => [ $item ], file => [ $item ] };
}
elsif ( ref $no_index eq 'ARRAY' ) {
my $list = $no_index;
$no_index = { dir => [ @$list ], file => [ @$list ] };
}
# common mistake: files -> file
if ( exists $no_index->{files} ) {
$no_index->{file} = delete $no_index->{file};
}
# common mistake: modules -> module
if ( exists $no_index->{modules} ) {
$no_index->{module} = delete $no_index->{module};
}
return _convert($no_index, $no_index_spec_1_2);
}
sub _no_index_directory {
my ($element, $key, $meta, $version) = @_;
return unless $element;
# cleanup wrong format
if ( ! ref $element ) {
my $item = $element;
$element = { directory => [ $item ], file => [ $item ] };
}
elsif ( ref $element eq 'ARRAY' ) {
my $list = $element;
$element = { directory => [ @$list ], file => [ @$list ] };
}
if ( exists $element->{dir} ) {
$element->{directory} = delete $element->{dir};
}
# common mistake: files -> file
if ( exists $element->{files} ) {
$element->{file} = delete $element->{file};
}
# common mistake: modules -> module
if ( exists $element->{modules} ) {
$element->{module} = delete $element->{module};
}
my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
return _convert($element, $spec);
}
sub _is_module_name {
my $mod = shift;
return unless defined $mod && length $mod;
return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
}
sub _clean_version {
my ($element) = @_;
return 0 if ! defined $element;
$element =~ s{^\s*}{};
$element =~ s{\s*$}{};
$element =~ s{^\.}{0.};
return 0 if ! length $element;
return 0 if ( $element eq 'undef' || $element eq '<undef>' );
my $v = eval { version->new($element) };
# XXX check defined $v and not just $v because version objects leak memory
# in boolean context -- dagolden, 2012-02-03
if ( defined $v ) {
return _is_qv($v) ? $v->normal : $element;
}
else {
return 0;
}
}
sub _bad_version_hook {
my ($v) = @_;
$v =~ s{[a-z]+$}{}; # strip trailing alphabetics
my $vobj = eval { version->new($v) };
return defined($vobj) ? $vobj : version->new(0); # or give up
}
sub _version_map {
my ($element) = @_;
return unless defined $element;
if ( ref $element eq 'HASH' ) {
# XXX turn this into CPAN::Meta::Requirements with bad version hook
# and then turn it back into a hash
my $new_map = CPAN::Meta::Requirements->new(
{ bad_version_hook => \&_bad_version_hook } # punt
);
while ( my ($k,$v) = each %$element ) {
next unless _is_module_name($k);
if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
$v = 0;
}
# some weird, old META have bad yml with module => module
# so check if value is like a module name and not like a version
if ( _is_module_name($v) && ! version::is_lax($v) ) {
$new_map->add_minimum($k => 0);
$new_map->add_minimum($v => 0);
}
$new_map->add_string_requirement($k => $v);
}
return $new_map->as_string_hash;
}
elsif ( ref $element eq 'ARRAY' ) {
my $hashref = { map { $_ => 0 } @$element };
return _version_map($hashref); # cleanup any weird stuff
}
elsif ( ref $element eq '' && length $element ) {
return { $element => 0 }
}
return;
}
sub _prereqs_from_1 {
my (undef, undef, $meta) = @_;
my $prereqs = {};
for my $phase ( qw/build configure/ ) {
my $key = "${phase}_requires";
$prereqs->{$phase}{requires} = _version_map($meta->{$key})
if $meta->{$key};
}
for my $rel ( qw/requires recommends conflicts/ ) {
$prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
if $meta->{$rel};
}
return $prereqs;
}
my $prereqs_spec = {
configure => \&_prereqs_rel,
build => \&_prereqs_rel,
test => \&_prereqs_rel,
runtime => \&_prereqs_rel,
develop => \&_prereqs_rel,
':custom' => \&_prefix_custom,
};
my $relation_spec = {
requires => \&_version_map,
recommends => \&_version_map,
suggests => \&_version_map,
conflicts => \&_version_map,
':custom' => \&_prefix_custom,
};
sub _cleanup_prereqs {
my ($prereqs, $key, $meta, $to_version) = @_;
return unless $prereqs && ref $prereqs eq 'HASH';
return _convert( $prereqs, $prereqs_spec, $to_version );
}
sub _prereqs_rel {
my ($relation, $key, $meta, $to_version) = @_;
return unless $relation && ref $relation eq 'HASH';
return _convert( $relation, $relation_spec, $to_version );
}
BEGIN {
my @old_prereqs = qw(
requires
configure_requires
recommends
conflicts
);
for ( @old_prereqs ) {
my $sub = "_get_$_";
my ($phase,$type) = split qr/_/, $_;
if ( ! defined $type ) {
$type = $phase;
$phase = 'runtime';
}
no strict 'refs';
*{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
}
}
sub _get_build_requires {
my ($data, $key, $meta) = @_;
my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
$test_req->add_requirements($build_req)->as_string_hash;
}
sub _extract_prereqs {
my ($prereqs, $phase, $type) = @_;
return unless ref $prereqs eq 'HASH';
return scalar _version_map($prereqs->{$phase}{$type});
}
sub _downgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
};
for my $k (keys %{$features->{$name}} ) {
delete $features->{$name}{$k} unless defined $features->{$name}{$k};
}
}
return $features;
}
sub _upgrade_optional_features {
my (undef, undef, $meta) = @_;
return unless exists $meta->{optional_features};
my $origin = $meta->{optional_features};
my $features = {};
for my $name ( keys %$origin ) {
$features->{$name} = {
description => $origin->{$name}{description},
prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
};
delete $features->{$name}{prereqs}{configure};
}
return $features;
}
my $optional_features_2_spec = {
description => \&_keep,
prereqs => \&_cleanup_prereqs,
':custom' => \&_prefix_custom,
};
sub _feature_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
_convert( $element, $optional_features_2_spec, $to_version );
}
sub _cleanup_optional_features_2 {
my ($element, $key, $meta, $to_version) = @_;
return unless $element && ref $element eq 'HASH';
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
}
return unless keys %$new_data;
return $new_data;
}
sub _optional_features_1_4 {
my ($element) = @_;
return unless $element;
$element = _optional_features_as_map($element);
for my $name ( keys %$element ) {
for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
delete $element->{$name}{$drop};
}
}
return $element;
}
sub _optional_features_as_map {
my ($element) = @_;
return unless $element;
if ( ref $element eq 'ARRAY' ) {
my %map;
for my $feature ( @$element ) {
my (@parts) = %$feature;
$map{$parts[0]} = $parts[1];
}
$element = \%map;
}
return $element;
}
sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
sub _url_or_drop {
my ($element) = @_;
return $element if _is_urlish($element);
return;
}
sub _url_list {
my ($element) = @_;
return unless $element;
$element = _listify( $element );
$element = [ grep { _is_urlish($_) } @$element ];
return unless @$element;
return $element;
}
sub _author_list {
my ($element) = @_;
return [ 'unknown' ] unless $element;
$element = _listify( $element );
$element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
return [ 'unknown' ] unless @$element;
return $element;
}
my $resource2_upgrade = {
license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
homepage => \&_url_or_drop,
bugtracker => sub {
my ($item) = @_;
return unless $item;
if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
elsif( _is_urlish($item) ) { return { web => $item } }
else { return }
},
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
':custom' => \&_prefix_custom,
};
sub _upgrade_resources_2 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource2_upgrade);
}
my $bugtracker2_spec = {
web => \&_url_or_drop,
mailto => \&_keep,
':custom' => \&_prefix_custom,
};
sub _repo_type {
my ($element, $key, $meta, $to_version) = @_;
return $element if defined $element;
return unless exists $meta->{url};
my $repo_url = $meta->{url};
for my $type ( qw/git svn/ ) {
return $type if $repo_url =~ m{\A$type};
}
return;
}
my $repository2_spec = {
web => \&_url_or_drop,
url => \&_url_or_drop,
type => \&_repo_type,
':custom' => \&_prefix_custom,
};
my $resources2_cleanup = {
license => \&_url_list,
homepage => \&_url_or_drop,
bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
':custom' => \&_prefix_custom,
};
sub _cleanup_resources_2 {
my ($resources, $key, $meta, $to_version) = @_;
return unless $resources && ref $resources eq 'HASH';
return _convert($resources, $resources2_cleanup, $to_version);
}
my $resource1_spec = {
license => \&_url_or_drop,
homepage => \&_url_or_drop,
bugtracker => \&_url_or_drop,
repository => \&_url_or_drop,
':custom' => \&_keep,
};
sub _resources_1_3 {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource1_spec);
}
*_resources_1_4 = *_resources_1_3;
sub _resources_1_2 {
my (undef, undef, $meta) = @_;
my $resources = $meta->{resources} || {};
if ( $meta->{license_url} && ! $resources->{license} ) {
$resources->{license} = $meta->{license_url}
if _is_urlish($meta->{license_url});
}
return unless keys %$resources;
return _convert($resources, $resource1_spec);
}
my $resource_downgrade_spec = {
license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
homepage => \&_url_or_drop,
bugtracker => sub { return $_[0]->{web} },
repository => sub { return $_[0]->{url} || $_[0]->{web} },
':custom' => \&_no_prefix_ucfirst_custom,
};
sub _downgrade_resources {
my (undef, undef, $meta, $version) = @_;
return unless exists $meta->{resources};
return _convert($meta->{resources}, $resource_downgrade_spec);
}
sub _release_status {
my ($element, undef, $meta) = @_;
return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
return _release_status_from_version(undef, undef, $meta);
}
sub _release_status_from_version {
my (undef, undef, $meta) = @_;
my $version = $meta->{version} || '';
return ( $version =~ /_/ ) ? 'testing' : 'stable';
}
my $provides_spec = {
file => \&_keep,
version => \&_keep,
};
my $provides_spec_2 = {
file => \&_keep,
version => \&_keep,
':custom' => \&_prefix_custom,
};
sub _provides {
my ($element, $key, $meta, $to_version) = @_;
return unless defined $element && ref $element eq 'HASH';
my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
my $new_data = {};
for my $k ( keys %$element ) {
$new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
$new_data->{$k}{version} = _clean_version($element->{$k}{version})
if exists $element->{$k}{version};
}
return $new_data;
}
sub _convert {
my ($data, $spec, $to_version, $is_fragment) = @_;
my $new_data = {};
for my $key ( keys %$spec ) {
next if $key eq ':custom' || $key eq ':drop';
next unless my $fcn = $spec->{$key};
if ( $is_fragment && $key eq 'generated_by' ) {
$fcn = \&_keep;
}
die "spec for '$key' is not a coderef"
unless ref $fcn && ref $fcn eq 'CODE';
my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
$new_data->{$key} = $new_value if defined $new_value;
}
my $drop_list = $spec->{':drop'};
my $customizer = $spec->{':custom'} || \&_keep;
for my $key ( keys %$data ) {
next if $drop_list && grep { $key eq $_ } @$drop_list;
next if exists $spec->{$key}; # we handled it
$new_data->{ $customizer->($key) } = $data->{$key};
}
return $new_data;
}
#--------------------------------------------------------------------------#
# define converters for each conversion
#--------------------------------------------------------------------------#
# each converts from prior version
# special ":custom" field is used for keys not recognized in spec
my %up_convert = (
'2-from-1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status_from_version,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_upgrade_optional_features,
'provides' => \&_provides,
'resources' => \&_upgrade_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_prereqs_from_1,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4-from-1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3-from-1.2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2-from-1.1' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
license_url
private
)],
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1-from-1.0' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
);
my %down_convert = (
'1.4-from-2' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_downgrade_license,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_get_build_requires,
'configure_requires' => \&_get_configure_requires,
'conflicts' => \&_get_conflicts,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_downgrade_optional_features,
'provides' => \&_provides,
'recommends' => \&_get_recommends,
'requires' => \&_get_requires,
'resources' => \&_downgrade_resources,
# drop these unsupported fields (after conversion)
':drop' => [ qw(
description
prereqs
release_status
)],
# custom keys will be left unchanged
':custom' => \&_keep
},
'1.3-from-1.4' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# drop these unsupported fields, but only after we convert
':drop' => [ qw(
configure_requires
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.2-from-1.3' => {
# MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.1-from-1.2' => {
# MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'private' => \&_keep,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# drop unsupported fields
':drop' => [ qw(
abstract
author
provides
no_index
keywords
resources
)],
# other random keys are OK if already valid
':custom' => \&_keep,
},
'1.0-from-1.1' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
my %cleanup = (
'2' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_2,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# CHANGED TO MANDATORY
'dynamic_config' => \&_keep_or_one,
# ADDED MANDATORY
'release_status' => \&_release_status,
# PRIOR OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_cleanup_optional_features_2,
'provides' => \&_provides,
'resources' => \&_cleanup_resources_2,
# ADDED OPTIONAL
'description' => \&_keep,
'prereqs' => \&_cleanup_prereqs,
# drop these deprecated fields, but only after we convert
':drop' => [ qw(
build_requires
configure_requires
conflicts
distribution_type
license_url
private
recommends
requires
) ],
# other random keys need x_ prefixing
':custom' => \&_prefix_custom,
},
'1.4' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_1_4,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_4,
# ADDED OPTIONAL
'configure_requires' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.3' => {
# PRIOR MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'meta-spec' => \&_change_meta_spec,
'name' => \&_keep,
'version' => \&_keep,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'keywords' => \&_keep,
'no_index' => \&_no_index_directory,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'recommends' => \&_version_map,
'requires' => \&_version_map,
'resources' => \&_resources_1_3,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.2' => {
# PRIOR MANDATORY
'version' => \&_keep,
# CHANGED TO MANDATORY
'license' => \&_license_1,
'name' => \&_keep,
'generated_by' => \&_generated_by,
# ADDED MANDATORY
'abstract' => \&_keep_or_unknown,
'author' => \&_author_list,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'keywords' => \&_keep,
'no_index' => \&_no_index_1_2,
'optional_features' => \&_optional_features_as_map,
'provides' => \&_provides,
'resources' => \&_resources_1_2,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.1' => {
# CHANGED TO MANDATORY
'version' => \&_keep,
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
# PRIOR OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# ADDED OPTIONAL
'license_url' => \&_url_or_drop,
'private' => \&_keep,
# other random keys are OK if already valid
':custom' => \&_keep
},
'1.0' => {
# IMPLIED MANDATORY
'name' => \&_keep,
'meta-spec' => \&_change_meta_spec,
'version' => \&_keep,
# IMPLIED OPTIONAL
'build_requires' => \&_version_map,
'conflicts' => \&_version_map,
'distribution_type' => \&_keep,
'dynamic_config' => \&_keep_or_one,
'generated_by' => \&_generated_by,
'license' => \&_license_1,
'recommends' => \&_version_map,
'requires' => \&_version_map,
# other random keys are OK if already valid
':custom' => \&_keep,
},
);
# for a given field in a spec version, what fields will it feed
# into in the *latest* spec (i.e. v2); meta-spec omitted because
# we always expect a meta-spec to be generated
my %fragments_generate = (
'2' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'dynamic_config' => 'dynamic_config',
'release_status' => 'release_status',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'resources' => 'resources',
'description' => 'description',
'prereqs' => 'prereqs',
},
'1.4' => {
'abstract' => 'abstract',
'author' => 'author',
'generated_by' => 'generated_by',
'license' => 'license',
'name' => 'name',
'version' => 'version',
'build_requires' => 'prereqs',
'conflicts' => 'prereqs',
'distribution_type' => 'distribution_type',
'dynamic_config' => 'dynamic_config',
'keywords' => 'keywords',
'no_index' => 'no_index',
'optional_features' => 'optional_features',
'provides' => 'provides',
'recommends' => 'prereqs',
'requires' => 'prereqs',
'resources' => 'resources',
'configure_requires' => 'prereqs',
},
);
# this is not quite true but will work well enough
# as 1.4 is a superset of earlier ones
$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
#--------------------------------------------------------------------------#
# Code
#--------------------------------------------------------------------------#
#pod =method new
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct );
#pod
#pod The constructor should be passed a valid metadata structure but invalid
#pod structures are accepted. If no meta-spec version is provided, version 1.0 will
#pod be assumed.
#pod
#pod Optionally, you can provide a C<default_version> argument after C<$struct>:
#pod
#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
#pod
#pod This is only needed when converting a metadata fragment that does not include a
#pod C<meta-spec> field.
#pod
#pod =cut
sub new {
my ($class,$data,%args) = @_;
# create an attributes hash
my $self = {
'data' => $data,
'spec' => _extract_spec_version($data, $args{default_version}),
};
# create the object
return bless $self, $class;
}
sub _extract_spec_version {
my ($data, $default) = @_;
my $spec = $data->{'meta-spec'};
# is meta-spec there and valid?
return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
# does the version key look like a valid version?
my $v = $spec->{version};
if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
}
# otherwise, use heuristics: look for 1.x vs 2.0 fields
return "2" if exists $data->{prereqs};
return "1.4" if exists $data->{configure_requires};
return( $default || "1.2" ); # when meta-spec was first defined
}
#pod =method convert
#pod
#pod my $new_struct = $cmc->convert( version => "2" );
#pod
#pod Returns a new hash reference with the metadata converted to a different form.
#pod C<convert> will die if any conversion/standardization still results in an
#pod invalid structure.
#pod
#pod Valid parameters include:
#pod
#pod =over
#pod
#pod =item *
#pod
#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
#pod Defaults to the latest version of the CPAN Meta Spec.
#pod
#pod =back
#pod
#pod Conversion proceeds through each version in turn. For example, a version 1.2
#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
#pod conversion process attempts to clean-up simple errors and standardize data.
#pod For example, if C<author> is given as a scalar, it will converted to an array
#pod reference containing the item. (Converting a structure to its own version will
#pod also clean-up and standardize.)
#pod
#pod When data are cleaned and standardized, missing or invalid fields will be
#pod replaced with sensible defaults when possible. This may be lossy or imprecise.
#pod For example, some badly structured META.yml files on CPAN have prerequisite
#pod modules listed as both keys and values:
#pod
#pod requires => { 'Foo::Bar' => 'Bam::Baz' }
#pod
#pod These would be split and each converted to a prerequisite with a minimum
#pod version of zero.
#pod
#pod When some mandatory fields are missing or invalid, the conversion will attempt
#pod to provide a sensible default or will fill them with a value of 'unknown'. For
#pod example a missing or unrecognized C<license> field will result in a C<license>
#pod field of 'unknown'. Fields that may get an 'unknown' include:
#pod
#pod =for :list
#pod * abstract
#pod * author
#pod * license
#pod
#pod =cut
sub convert {
my ($self, %args) = @_;
my $args = { %args };
my $new_version = $args->{version} || $HIGHEST;
my $is_fragment = $args->{is_fragment};
my ($old_version) = $self->{spec};
my $converted = _dclone($self->{data});
if ( $old_version == $new_version ) {
$converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
}
}
return $converted;
}
elsif ( $old_version > $new_version ) {
my @vers = sort { $b <=> $a } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] > $old_version;
last if $vers[$i+1] < $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
else {
my @vers = sort { $a <=> $b } keys %known_specs;
for my $i ( 0 .. $#vers-1 ) {
next if $vers[$i] < $old_version;
last if $vers[$i+1] > $new_version;
my $spec_string = "$vers[$i+1]-from-$vers[$i]";
$converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
unless ( $args->{is_fragment} ) {
my $cmv = CPAN::Meta::Validator->new( $converted );
unless ( $cmv->is_valid ) {
my $errs = join("\n", $cmv->errors);
die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
}
}
}
return $converted;
}
}
#pod =method upgrade_fragment
#pod
#pod my $new_struct = $cmc->upgrade_fragment;
#pod
#pod Returns a new hash reference with the metadata converted to the latest version
#pod of the CPAN Meta Spec. No validation is done on the result -- you must
#pod validate after merging fragments into a complete metadata document.
#pod
#pod =cut
sub upgrade_fragment {
my ($self) = @_;
my ($old_version) = $self->{spec};
my %expected =
map {; $_ => 1 }
grep { defined }
map { $fragments_generate{$old_version}{$_} }
keys %{ $self->{data} };
my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
for my $key ( keys %$converted ) {
next if $key =~ /^x_/i || $key eq 'meta-spec';
delete $converted->{$key} unless $expected{$key};
}
return $converted;
}
1;
# ABSTRACT: Convert CPAN distribution metadata structures
=pod
=encoding UTF-8
=head1 NAME
CPAN::Meta::Converter - Convert CPAN distribution metadata structures
=head1 VERSION
version 2.143240
=head1 SYNOPSIS
my $struct = decode_json_file('META.json');
my $cmc = CPAN::Meta::Converter->new( $struct );
my $new_struct = $cmc->convert( version => "2" );
=head1 DESCRIPTION
This module converts CPAN Meta structures from one form to another. The
primary use is to convert older structures to the most modern version of
the specification, but other transformations may be implemented in the
future as needed. (E.g. stripping all custom fields or stripping all
optional fields.)
=head1 METHODS
=head2 new
my $cmc = CPAN::Meta::Converter->new( $struct );
The constructor should be passed a valid metadata structure but invalid
structures are accepted. If no meta-spec version is provided, version 1.0 will
be assumed.
Optionally, you can provide a C<default_version> argument after C<$struct>:
my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
This is only needed when converting a metadata fragment that does not include a
C<meta-spec> field.
=head2 convert
my $new_struct = $cmc->convert( version => "2" );
Returns a new hash reference with the metadata converted to a different form.
C<convert> will die if any conversion/standardization still results in an
invalid structure.
Valid parameters include:
=over
=item *
C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
Defaults to the latest version of the CPAN Meta Spec.
=back
Conversion proceeds through each version in turn. For example, a version 1.2
structure might be converted to 1.3 then 1.4 then finally to version 2. The
conversion process attempts to clean-up simple errors and standardize data.
For example, if C<author> is given as a scalar, it will converted to an array
reference containing the item. (Converting a structure to its own version will
also clean-up and standardize.)
When data are cleaned and standardized, missing or invalid fields will be
replaced with sensible defaults when possible. This may be lossy or imprecise.
For example, some badly structured META.yml files on CPAN have prerequisite
modules listed as both keys and values:
requires => { 'Foo::Bar' => 'Bam::Baz' }
These would be split and each converted to a prerequisite with a minimum
version of zero.
When some mandatory fields are missing or invalid, the conversion will attempt
to provide a sensible default or will fill them with a value of 'unknown'. For
example a missing or unrecognized C<license> field will result in a C<license>
field of 'unknown'. Fields that may get an 'unknown' include:
=over 4
=item *
abstract
=item *
author
=item *
license
=back
=head2 upgrade_fragment
my $new_struct = $cmc->upgrade_fragment;
Returns a new hash reference with the metadata converted to the latest version
of the CPAN Meta Spec. No validation is done on the result -- you must
validate after merging fragments into a complete metadata document.
=head1 BUGS
Please report any bugs or feature using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 AUTHORS
=over 4
=item *
David Golden <dagolden@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2010 by David Golden and Ricardo Signes.
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
__END__
# vim: ts=2 sts=2 sw=2 et:
Mini Shell