diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm | 118 |
1 files changed, 73 insertions, 45 deletions
diff --git a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm index 2c6ce857d3d..0348e55504e 100644 --- a/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm +++ b/Master/tlpkg/tlperl/lib/CPAN/Meta/Converter.pm @@ -2,15 +2,29 @@ use 5.006; use strict; use warnings; package CPAN::Meta::Converter; -BEGIN { - $CPAN::Meta::Converter::VERSION = '2.110440'; -} -# ABSTRACT: Convert CPAN distribution metadata structures +our $VERSION = '2.120630'; # VERSION use CPAN::Meta::Validator; -use Storable qw/dclone/; -use version 0.82 (); +use CPAN::Meta::Requirements; +use version 0.88 (); +use Parse::CPAN::Meta 1.4400 (); + +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'; + local *UNIVERSAL::TO_JSON = sub { return "$_[0]" }; + + my $backend = Parse::CPAN::Meta->json_backend(); + return $backend->new->utf8->decode( + $backend->new->utf8->allow_blessed->convert_blessed->encode($ref) + ); +} my %known_specs = ( '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', @@ -134,15 +148,18 @@ my @valid_licenses_2 = qw( 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', - artistic => 'artistic_1', - artistic2 => 'artistic_2', - gpl => 'gpl_1', - lgpl => 'lgpl_2_1', - mozilla => 'mozilla_1_0', - perl => 'perl_5', + (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', ); @@ -300,7 +317,10 @@ sub _clean_version { return 0 if ! length $element; return 0 if ( $element eq 'undef' || $element eq '<undef>' ); - if ( my $v = eval { version->new($element) } ) { + 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 $v->is_qv ? $v->normal : $element; } else { @@ -308,29 +328,36 @@ sub _clean_version { } } +sub _bad_version_hook { + my ($v) = @_; + $v =~ s{[a-z]+$}{}; # strip trailing alphabetics + my $vobj = eval { version->parse($v) }; + return defined($vobj) ? $vobj : version->parse(0); # or give up +} + sub _version_map { my ($element) = @_; - return undef unless defined $element; + return unless defined $element; if ( ref $element eq 'HASH' ) { - my $new_map = {}; - for my $k ( keys %$element ) { + # 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 => sub { version->new(0) } } # punt + ); + while ( my ($k,$v) = each %$element ) { next unless _is_module_name($k); - my $value = $element->{$k}; - if ( ! ( defined $value && length $value ) ) { - $new_map->{$k} = 0; - } - elsif ( $value eq 'undef' || $value eq '<undef>' ) { - $new_map->{$k} = 0; + if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) { + $v = 0; } - elsif ( _is_module_name( $value ) ) { # some weird, old META have this - $new_map->{$k} = 0; - $new_map->{$value} = 0; - } - else { - $new_map->{$k} = _clean_version($value); + # 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; + return $new_map->as_string_hash; } elsif ( ref $element eq 'ARRAY' ) { my $hashref = { map { $_ => 0 } @$element }; @@ -413,9 +440,8 @@ sub _get_build_requires { my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; - require Version::Requirements; - my $test_req = Version::Requirements->from_string_hash($test_h); - my $build_req = Version::Requirements->from_string_hash($build_h); + 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; } @@ -423,12 +449,12 @@ sub _get_build_requires { sub _extract_prereqs { my ($prereqs, $phase, $type) = @_; return unless ref $prereqs eq 'HASH'; - return $prereqs->{$phase}{$type}; + return scalar _version_map($prereqs->{$phase}{$type}); } sub _downgrade_optional_features { my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; + return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { @@ -449,7 +475,7 @@ sub _downgrade_optional_features { sub _upgrade_optional_features { my (undef, undef, $meta) = @_; - return undef unless exists $meta->{optional_features}; + return unless exists $meta->{optional_features}; my $origin = $meta->{optional_features}; my $features = {}; for my $name ( keys %$origin ) { @@ -545,7 +571,7 @@ my $resource2_upgrade = { return unless $item; if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } elsif( _is_urlish($item) ) { return { web => $item } } - else { return undef } + else { return } }, repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, ':custom' => \&_prefix_custom, @@ -553,7 +579,7 @@ my $resource2_upgrade = { sub _upgrade_resources_2 { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource2_upgrade); } @@ -591,7 +617,7 @@ my $resources2_cleanup = { sub _cleanup_resources_2 { my ($resources, $key, $meta, $to_version) = @_; - return undef unless $resources && ref $resources eq 'HASH'; + return unless $resources && ref $resources eq 'HASH'; return _convert($resources, $resources2_cleanup, $to_version); } @@ -605,7 +631,7 @@ my $resource1_spec = { sub _resources_1_3 { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource1_spec); } @@ -618,7 +644,7 @@ sub _resources_1_2 { $resources->{license} = $meta->license_url if _is_urlish($meta->{license_url}); } - return undef unless keys %$resources; + return unless keys %$resources; return _convert($resources, $resource1_spec); } @@ -632,7 +658,7 @@ my $resource_downgrade_spec = { sub _downgrade_resources { my (undef, undef, $meta, $version) = @_; - return undef unless exists $meta->{resources}; + return unless exists $meta->{resources}; return _convert($meta->{resources}, $resource_downgrade_spec); } @@ -1187,7 +1213,7 @@ sub convert { my $new_version = $args->{version} || $HIGHEST; my ($old_version) = $self->{spec}; - my $converted = dclone $self->{data}; + my $converted = _dclone($self->{data}); if ( $old_version == $new_version ) { $converted = _convert( $converted, $cleanup{$old_version}, $old_version ); @@ -1232,6 +1258,8 @@ sub convert { 1; +# ABSTRACT: Convert CPAN distribution metadata structures + =pod @@ -1242,7 +1270,7 @@ CPAN::Meta::Converter - Convert CPAN distribution metadata structures =head1 VERSION -version 2.110440 +version 2.120630 =head1 SYNOPSIS |