1use 5.006; 2use strict; 3use warnings; 4package CPAN::Meta::Converter; 5 6our $VERSION = '2.150010'; 7 8#pod =head1 SYNOPSIS 9#pod 10#pod my $struct = decode_json_file('META.json'); 11#pod 12#pod my $cmc = CPAN::Meta::Converter->new( $struct ); 13#pod 14#pod my $new_struct = $cmc->convert( version => "2" ); 15#pod 16#pod =head1 DESCRIPTION 17#pod 18#pod This module converts CPAN Meta structures from one form to another. The 19#pod primary use is to convert older structures to the most modern version of 20#pod the specification, but other transformations may be implemented in the 21#pod future as needed. (E.g. stripping all custom fields or stripping all 22#pod optional fields.) 23#pod 24#pod =cut 25 26use CPAN::Meta::Validator; 27use CPAN::Meta::Requirements; 28use Parse::CPAN::Meta 1.4400 (); 29 30# To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls 31# before 5.10, we fall back to the EUMM bundled compatibility version module if 32# that's the only thing available. This shouldn't ever happen in a normal CPAN 33# install of CPAN::Meta::Requirements, as version.pm will be picked up from 34# prereqs and be available at runtime. 35 36BEGIN { 37 eval "use version ()"; ## no critic 38 if ( my $err = $@ ) { 39 eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic 40 } 41} 42 43# Perl 5.10.0 didn't have "is_qv" in version.pm 44*_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; 45 46# We limit cloning to a maximum depth to bail out on circular data 47# structures. While actual cycle detection might be technically better, 48# we expect circularity in META data structures to be rare and generally 49# the result of user error. Therefore, a depth counter is lower overhead. 50our $DCLONE_MAXDEPTH = 1024; 51our $_CLONE_DEPTH; 52 53sub _dclone { 54 my ( $ref ) = @_; 55 return $ref unless my $reftype = ref $ref; 56 57 local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH; 58 die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0; 59 60 return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype; 61 return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype; 62 63 if ( 'SCALAR' eq $reftype ) { 64 my $new = _dclone(${$ref}); 65 return \$new; 66 } 67 68 # We can't know if TO_JSON gives us cloned data, so refs must recurse 69 if ( eval { $ref->can('TO_JSON') } ) { 70 my $data = $ref->TO_JSON; 71 return ref $data ? _dclone( $data ) : $data; 72 } 73 74 # Just stringify everything else 75 return "$ref"; 76} 77 78my %known_specs = ( 79 '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', 80 '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', 81 '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', 82 '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', 83 '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', 84 '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' 85); 86 87my @spec_list = sort { $a <=> $b } keys %known_specs; 88my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; 89 90#--------------------------------------------------------------------------# 91# converters 92# 93# called as $converter->($element, $field_name, $full_meta, $to_version) 94# 95# defined return value used for field 96# undef return value means field is skipped 97#--------------------------------------------------------------------------# 98 99sub _keep { $_[0] } 100 101sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } 102 103sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } 104 105sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } 106 107sub _generated_by { 108 my $gen = shift; 109 my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>"); 110 111 return $sig unless defined $gen and length $gen; 112 return $gen if $gen =~ /\Q$sig/; 113 return "$gen, $sig"; 114} 115 116sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } 117 118sub _prefix_custom { 119 my $key = shift; 120 $key =~ s/^(?!x_) # Unless it already starts with x_ 121 (?:x-?)? # Remove leading x- or x (if present) 122 /x_/ix; # and prepend x_ 123 return $key; 124} 125 126sub _ucfirst_custom { 127 my $key = shift; 128 $key = ucfirst $key unless $key =~ /[A-Z]/; 129 return $key; 130} 131 132sub _no_prefix_ucfirst_custom { 133 my $key = shift; 134 $key =~ s/^x_//; 135 return _ucfirst_custom($key); 136} 137 138sub _change_meta_spec { 139 my ($element, undef, undef, $version) = @_; 140 return { 141 version => $version, 142 url => $known_specs{$version}, 143 }; 144} 145 146my @open_source = ( 147 'perl', 148 'gpl', 149 'apache', 150 'artistic', 151 'artistic_2', 152 'lgpl', 153 'bsd', 154 'gpl', 155 'mit', 156 'mozilla', 157 'open_source', 158); 159 160my %is_open_source = map {; $_ => 1 } @open_source; 161 162my @valid_licenses_1 = ( 163 @open_source, 164 'unrestricted', 165 'restrictive', 166 'unknown', 167); 168 169my %license_map_1 = ( 170 ( map { $_ => $_ } @valid_licenses_1 ), 171 artistic2 => 'artistic_2', 172); 173 174sub _license_1 { 175 my ($element) = @_; 176 return 'unknown' unless defined $element; 177 if ( $license_map_1{lc $element} ) { 178 return $license_map_1{lc $element}; 179 } 180 else { 181 return 'unknown'; 182 } 183} 184 185my @valid_licenses_2 = qw( 186 agpl_3 187 apache_1_1 188 apache_2_0 189 artistic_1 190 artistic_2 191 bsd 192 freebsd 193 gfdl_1_2 194 gfdl_1_3 195 gpl_1 196 gpl_2 197 gpl_3 198 lgpl_2_1 199 lgpl_3_0 200 mit 201 mozilla_1_0 202 mozilla_1_1 203 openssl 204 perl_5 205 qpl_1_0 206 ssleay 207 sun 208 zlib 209 open_source 210 restricted 211 unrestricted 212 unknown 213); 214 215# The "old" values were defined by Module::Build, and were often vague. I have 216# made the decisions below based on reading Module::Build::API and how clearly 217# it specifies the version of the license. 218my %license_map_2 = ( 219 (map { $_ => $_ } @valid_licenses_2), 220 apache => 'apache_2_0', # clearly stated as 2.0 221 artistic => 'artistic_1', # clearly stated as 1 222 artistic2 => 'artistic_2', # clearly stated as 2 223 gpl => 'open_source', # we don't know which GPL; punt 224 lgpl => 'open_source', # we don't know which LGPL; punt 225 mozilla => 'open_source', # we don't know which MPL; punt 226 perl => 'perl_5', # clearly Perl 5 227 restrictive => 'restricted', 228); 229 230sub _license_2 { 231 my ($element) = @_; 232 return [ 'unknown' ] unless defined $element; 233 $element = [ $element ] unless ref $element eq 'ARRAY'; 234 my @new_list; 235 for my $lic ( @$element ) { 236 next unless defined $lic; 237 if ( my $new = $license_map_2{lc $lic} ) { 238 push @new_list, $new; 239 } 240 } 241 return @new_list ? \@new_list : [ 'unknown' ]; 242} 243 244my %license_downgrade_map = qw( 245 agpl_3 open_source 246 apache_1_1 apache 247 apache_2_0 apache 248 artistic_1 artistic 249 artistic_2 artistic_2 250 bsd bsd 251 freebsd open_source 252 gfdl_1_2 open_source 253 gfdl_1_3 open_source 254 gpl_1 gpl 255 gpl_2 gpl 256 gpl_3 gpl 257 lgpl_2_1 lgpl 258 lgpl_3_0 lgpl 259 mit mit 260 mozilla_1_0 mozilla 261 mozilla_1_1 mozilla 262 openssl open_source 263 perl_5 perl 264 qpl_1_0 open_source 265 ssleay open_source 266 sun open_source 267 zlib open_source 268 open_source open_source 269 restricted restrictive 270 unrestricted unrestricted 271 unknown unknown 272); 273 274sub _downgrade_license { 275 my ($element) = @_; 276 if ( ! defined $element ) { 277 return "unknown"; 278 } 279 elsif( ref $element eq 'ARRAY' ) { 280 if ( @$element > 1) { 281 if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) { 282 return 'unknown'; 283 } 284 else { 285 return 'open_source'; 286 } 287 } 288 elsif ( @$element == 1 ) { 289 return $license_downgrade_map{lc $element->[0]} || "unknown"; 290 } 291 } 292 elsif ( ! ref $element ) { 293 return $license_downgrade_map{lc $element} || "unknown"; 294 } 295 return "unknown"; 296} 297 298my $no_index_spec_1_2 = { 299 'file' => \&_listify, 300 'dir' => \&_listify, 301 'package' => \&_listify, 302 'namespace' => \&_listify, 303}; 304 305my $no_index_spec_1_3 = { 306 'file' => \&_listify, 307 'directory' => \&_listify, 308 'package' => \&_listify, 309 'namespace' => \&_listify, 310}; 311 312my $no_index_spec_2 = { 313 'file' => \&_listify, 314 'directory' => \&_listify, 315 'package' => \&_listify, 316 'namespace' => \&_listify, 317 ':custom' => \&_prefix_custom, 318}; 319 320sub _no_index_1_2 { 321 my (undef, undef, $meta) = @_; 322 my $no_index = $meta->{no_index} || $meta->{private}; 323 return unless $no_index; 324 325 # cleanup wrong format 326 if ( ! ref $no_index ) { 327 my $item = $no_index; 328 $no_index = { dir => [ $item ], file => [ $item ] }; 329 } 330 elsif ( ref $no_index eq 'ARRAY' ) { 331 my $list = $no_index; 332 $no_index = { dir => [ @$list ], file => [ @$list ] }; 333 } 334 335 # common mistake: files -> file 336 if ( exists $no_index->{files} ) { 337 $no_index->{file} = delete $no_index->{files}; 338 } 339 # common mistake: modules -> module 340 if ( exists $no_index->{modules} ) { 341 $no_index->{module} = delete $no_index->{modules}; 342 } 343 return _convert($no_index, $no_index_spec_1_2); 344} 345 346sub _no_index_directory { 347 my ($element, $key, $meta, $version) = @_; 348 return unless $element; 349 350 # clean up wrong format 351 if ( ! ref $element ) { 352 my $item = $element; 353 $element = { directory => [ $item ], file => [ $item ] }; 354 } 355 elsif ( ref $element eq 'ARRAY' ) { 356 my $list = $element; 357 $element = { directory => [ @$list ], file => [ @$list ] }; 358 } 359 360 if ( exists $element->{dir} ) { 361 $element->{directory} = delete $element->{dir}; 362 } 363 # common mistake: files -> file 364 if ( exists $element->{files} ) { 365 $element->{file} = delete $element->{files}; 366 } 367 # common mistake: modules -> module 368 if ( exists $element->{modules} ) { 369 $element->{module} = delete $element->{modules}; 370 } 371 my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; 372 return _convert($element, $spec); 373} 374 375sub _is_module_name { 376 my $mod = shift; 377 return unless defined $mod && length $mod; 378 return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; 379} 380 381sub _clean_version { 382 my ($element) = @_; 383 return 0 if ! defined $element; 384 385 $element =~ s{^\s*}{}; 386 $element =~ s{\s*$}{}; 387 $element =~ s{^\.}{0.}; 388 389 return 0 if ! length $element; 390 return 0 if ( $element eq 'undef' || $element eq '<undef>' ); 391 392 my $v = eval { version->new($element) }; 393 # XXX check defined $v and not just $v because version objects leak memory 394 # in boolean context -- dagolden, 2012-02-03 395 if ( defined $v ) { 396 return _is_qv($v) ? $v->normal : $element; 397 } 398 else { 399 return 0; 400 } 401} 402 403sub _bad_version_hook { 404 my ($v) = @_; 405 $v =~ s{^\s*}{}; 406 $v =~ s{\s*$}{}; 407 $v =~ s{[a-z]+$}{}; # strip trailing alphabetics 408 my $vobj = eval { version->new($v) }; 409 return defined($vobj) ? $vobj : version->new(0); # or give up 410} 411 412sub _version_map { 413 my ($element) = @_; 414 return unless defined $element; 415 if ( ref $element eq 'HASH' ) { 416 # XXX turn this into CPAN::Meta::Requirements with bad version hook 417 # and then turn it back into a hash 418 my $new_map = CPAN::Meta::Requirements->new( 419 { bad_version_hook => \&_bad_version_hook } # punt 420 ); 421 while ( my ($k,$v) = each %$element ) { 422 next unless _is_module_name($k); 423 if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) { 424 $v = 0; 425 } 426 # some weird, old META have bad yml with module => module 427 # so check if value is like a module name and not like a version 428 if ( _is_module_name($v) && ! version::is_lax($v) ) { 429 $new_map->add_minimum($k => 0); 430 $new_map->add_minimum($v => 0); 431 } 432 $new_map->add_string_requirement($k => $v); 433 } 434 return $new_map->as_string_hash; 435 } 436 elsif ( ref $element eq 'ARRAY' ) { 437 my $hashref = { map { $_ => 0 } @$element }; 438 return _version_map($hashref); # clean up any weird stuff 439 } 440 elsif ( ref $element eq '' && length $element ) { 441 return { $element => 0 } 442 } 443 return; 444} 445 446sub _prereqs_from_1 { 447 my (undef, undef, $meta) = @_; 448 my $prereqs = {}; 449 for my $phase ( qw/build configure/ ) { 450 my $key = "${phase}_requires"; 451 $prereqs->{$phase}{requires} = _version_map($meta->{$key}) 452 if $meta->{$key}; 453 } 454 for my $rel ( qw/requires recommends conflicts/ ) { 455 $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) 456 if $meta->{$rel}; 457 } 458 return $prereqs; 459} 460 461my $prereqs_spec = { 462 configure => \&_prereqs_rel, 463 build => \&_prereqs_rel, 464 test => \&_prereqs_rel, 465 runtime => \&_prereqs_rel, 466 develop => \&_prereqs_rel, 467 ':custom' => \&_prefix_custom, 468}; 469 470my $relation_spec = { 471 requires => \&_version_map, 472 recommends => \&_version_map, 473 suggests => \&_version_map, 474 conflicts => \&_version_map, 475 ':custom' => \&_prefix_custom, 476}; 477 478sub _cleanup_prereqs { 479 my ($prereqs, $key, $meta, $to_version) = @_; 480 return unless $prereqs && ref $prereqs eq 'HASH'; 481 return _convert( $prereqs, $prereqs_spec, $to_version ); 482} 483 484sub _prereqs_rel { 485 my ($relation, $key, $meta, $to_version) = @_; 486 return unless $relation && ref $relation eq 'HASH'; 487 return _convert( $relation, $relation_spec, $to_version ); 488} 489 490 491BEGIN { 492 my @old_prereqs = qw( 493 requires 494 configure_requires 495 recommends 496 conflicts 497 ); 498 499 for ( @old_prereqs ) { 500 my $sub = "_get_$_"; 501 my ($phase,$type) = split qr/_/, $_; 502 if ( ! defined $type ) { 503 $type = $phase; 504 $phase = 'runtime'; 505 } 506 no strict 'refs'; 507 *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; 508 } 509} 510 511sub _get_build_requires { 512 my ($data, $key, $meta) = @_; 513 514 my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; 515 my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; 516 517 my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); 518 my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); 519 520 $test_req->add_requirements($build_req)->as_string_hash; 521} 522 523sub _extract_prereqs { 524 my ($prereqs, $phase, $type) = @_; 525 return unless ref $prereqs eq 'HASH'; 526 return scalar _version_map($prereqs->{$phase}{$type}); 527} 528 529sub _downgrade_optional_features { 530 my (undef, undef, $meta) = @_; 531 return unless exists $meta->{optional_features}; 532 my $origin = $meta->{optional_features}; 533 my $features = {}; 534 for my $name ( keys %$origin ) { 535 $features->{$name} = { 536 description => $origin->{$name}{description}, 537 requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), 538 configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), 539 build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), 540 recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), 541 conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), 542 }; 543 for my $k (keys %{$features->{$name}} ) { 544 delete $features->{$name}{$k} unless defined $features->{$name}{$k}; 545 } 546 } 547 return $features; 548} 549 550sub _upgrade_optional_features { 551 my (undef, undef, $meta) = @_; 552 return unless exists $meta->{optional_features}; 553 my $origin = $meta->{optional_features}; 554 my $features = {}; 555 for my $name ( keys %$origin ) { 556 $features->{$name} = { 557 description => $origin->{$name}{description}, 558 prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), 559 }; 560 delete $features->{$name}{prereqs}{configure}; 561 } 562 return $features; 563} 564 565my $optional_features_2_spec = { 566 description => \&_keep, 567 prereqs => \&_cleanup_prereqs, 568 ':custom' => \&_prefix_custom, 569}; 570 571sub _feature_2 { 572 my ($element, $key, $meta, $to_version) = @_; 573 return unless $element && ref $element eq 'HASH'; 574 _convert( $element, $optional_features_2_spec, $to_version ); 575} 576 577sub _cleanup_optional_features_2 { 578 my ($element, $key, $meta, $to_version) = @_; 579 return unless $element && ref $element eq 'HASH'; 580 my $new_data = {}; 581 for my $k ( keys %$element ) { 582 $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); 583 } 584 return unless keys %$new_data; 585 return $new_data; 586} 587 588sub _optional_features_1_4 { 589 my ($element) = @_; 590 return unless $element; 591 $element = _optional_features_as_map($element); 592 for my $name ( keys %$element ) { 593 for my $drop ( qw/requires_packages requires_os excluded_os/ ) { 594 delete $element->{$name}{$drop}; 595 } 596 } 597 return $element; 598} 599 600sub _optional_features_as_map { 601 my ($element) = @_; 602 return unless $element; 603 if ( ref $element eq 'ARRAY' ) { 604 my %map; 605 for my $feature ( @$element ) { 606 my (@parts) = %$feature; 607 $map{$parts[0]} = $parts[1]; 608 } 609 $element = \%map; 610 } 611 return $element; 612} 613 614sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } 615 616sub _url_or_drop { 617 my ($element) = @_; 618 return $element if _is_urlish($element); 619 return; 620} 621 622sub _url_list { 623 my ($element) = @_; 624 return unless $element; 625 $element = _listify( $element ); 626 $element = [ grep { _is_urlish($_) } @$element ]; 627 return unless @$element; 628 return $element; 629} 630 631sub _author_list { 632 my ($element) = @_; 633 return [ 'unknown' ] unless $element; 634 $element = _listify( $element ); 635 $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; 636 return [ 'unknown' ] unless @$element; 637 return $element; 638} 639 640my $resource2_upgrade = { 641 license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, 642 homepage => \&_url_or_drop, 643 bugtracker => sub { 644 my ($item) = @_; 645 return unless $item; 646 if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } 647 elsif( _is_urlish($item) ) { return { web => $item } } 648 else { return } 649 }, 650 repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, 651 ':custom' => \&_prefix_custom, 652}; 653 654sub _upgrade_resources_2 { 655 my (undef, undef, $meta, $version) = @_; 656 return unless exists $meta->{resources}; 657 return _convert($meta->{resources}, $resource2_upgrade); 658} 659 660my $bugtracker2_spec = { 661 web => \&_url_or_drop, 662 mailto => \&_keep, 663 ':custom' => \&_prefix_custom, 664}; 665 666sub _repo_type { 667 my ($element, $key, $meta, $to_version) = @_; 668 return $element if defined $element; 669 return unless exists $meta->{url}; 670 my $repo_url = $meta->{url}; 671 for my $type ( qw/git svn/ ) { 672 return $type if $repo_url =~ m{\A$type}; 673 } 674 return; 675} 676 677my $repository2_spec = { 678 web => \&_url_or_drop, 679 url => \&_url_or_drop, 680 type => \&_repo_type, 681 ':custom' => \&_prefix_custom, 682}; 683 684my $resources2_cleanup = { 685 license => \&_url_list, 686 homepage => \&_url_or_drop, 687 bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, 688 repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, 689 ':custom' => \&_prefix_custom, 690}; 691 692sub _cleanup_resources_2 { 693 my ($resources, $key, $meta, $to_version) = @_; 694 return unless $resources && ref $resources eq 'HASH'; 695 return _convert($resources, $resources2_cleanup, $to_version); 696} 697 698my $resource1_spec = { 699 license => \&_url_or_drop, 700 homepage => \&_url_or_drop, 701 bugtracker => \&_url_or_drop, 702 repository => \&_url_or_drop, 703 ':custom' => \&_keep, 704}; 705 706sub _resources_1_3 { 707 my (undef, undef, $meta, $version) = @_; 708 return unless exists $meta->{resources}; 709 return _convert($meta->{resources}, $resource1_spec); 710} 711 712*_resources_1_4 = *_resources_1_3; 713 714sub _resources_1_2 { 715 my (undef, undef, $meta) = @_; 716 my $resources = $meta->{resources} || {}; 717 if ( $meta->{license_url} && ! $resources->{license} ) { 718 $resources->{license} = $meta->{license_url} 719 if _is_urlish($meta->{license_url}); 720 } 721 return unless keys %$resources; 722 return _convert($resources, $resource1_spec); 723} 724 725my $resource_downgrade_spec = { 726 license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, 727 homepage => \&_url_or_drop, 728 bugtracker => sub { return $_[0]->{web} }, 729 repository => sub { return $_[0]->{url} || $_[0]->{web} }, 730 ':custom' => \&_no_prefix_ucfirst_custom, 731}; 732 733sub _downgrade_resources { 734 my (undef, undef, $meta, $version) = @_; 735 return unless exists $meta->{resources}; 736 return _convert($meta->{resources}, $resource_downgrade_spec); 737} 738 739sub _release_status { 740 my ($element, undef, $meta) = @_; 741 return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; 742 return _release_status_from_version(undef, undef, $meta); 743} 744 745sub _release_status_from_version { 746 my (undef, undef, $meta) = @_; 747 my $version = $meta->{version} || ''; 748 return ( $version =~ /_/ ) ? 'testing' : 'stable'; 749} 750 751my $provides_spec = { 752 file => \&_keep, 753 version => \&_keep, 754}; 755 756my $provides_spec_2 = { 757 file => \&_keep, 758 version => \&_keep, 759 ':custom' => \&_prefix_custom, 760}; 761 762sub _provides { 763 my ($element, $key, $meta, $to_version) = @_; 764 return unless defined $element && ref $element eq 'HASH'; 765 my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; 766 my $new_data = {}; 767 for my $k ( keys %$element ) { 768 $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); 769 $new_data->{$k}{version} = _clean_version($element->{$k}{version}) 770 if exists $element->{$k}{version}; 771 } 772 return $new_data; 773} 774 775sub _convert { 776 my ($data, $spec, $to_version, $is_fragment) = @_; 777 778 my $new_data = {}; 779 for my $key ( keys %$spec ) { 780 next if $key eq ':custom' || $key eq ':drop'; 781 next unless my $fcn = $spec->{$key}; 782 if ( $is_fragment && $key eq 'generated_by' ) { 783 $fcn = \&_keep; 784 } 785 die "spec for '$key' is not a coderef" 786 unless ref $fcn && ref $fcn eq 'CODE'; 787 my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); 788 $new_data->{$key} = $new_value if defined $new_value; 789 } 790 791 my $drop_list = $spec->{':drop'}; 792 my $customizer = $spec->{':custom'} || \&_keep; 793 794 for my $key ( keys %$data ) { 795 next if $drop_list && grep { $key eq $_ } @$drop_list; 796 next if exists $spec->{$key}; # we handled it 797 $new_data->{ $customizer->($key) } = $data->{$key}; 798 } 799 800 return $new_data; 801} 802 803#--------------------------------------------------------------------------# 804# define converters for each conversion 805#--------------------------------------------------------------------------# 806 807# each converts from prior version 808# special ":custom" field is used for keys not recognized in spec 809my %up_convert = ( 810 '2-from-1.4' => { 811 # PRIOR MANDATORY 812 'abstract' => \&_keep_or_unknown, 813 'author' => \&_author_list, 814 'generated_by' => \&_generated_by, 815 'license' => \&_license_2, 816 'meta-spec' => \&_change_meta_spec, 817 'name' => \&_keep, 818 'version' => \&_keep, 819 # CHANGED TO MANDATORY 820 'dynamic_config' => \&_keep_or_one, 821 # ADDED MANDATORY 822 'release_status' => \&_release_status, 823 # PRIOR OPTIONAL 824 'keywords' => \&_keep, 825 'no_index' => \&_no_index_directory, 826 'optional_features' => \&_upgrade_optional_features, 827 'provides' => \&_provides, 828 'resources' => \&_upgrade_resources_2, 829 # ADDED OPTIONAL 830 'description' => \&_keep, 831 'prereqs' => \&_prereqs_from_1, 832 833 # drop these deprecated fields, but only after we convert 834 ':drop' => [ qw( 835 build_requires 836 configure_requires 837 conflicts 838 distribution_type 839 license_url 840 private 841 recommends 842 requires 843 ) ], 844 845 # other random keys need x_ prefixing 846 ':custom' => \&_prefix_custom, 847 }, 848 '1.4-from-1.3' => { 849 # PRIOR MANDATORY 850 'abstract' => \&_keep_or_unknown, 851 'author' => \&_author_list, 852 'generated_by' => \&_generated_by, 853 'license' => \&_license_1, 854 'meta-spec' => \&_change_meta_spec, 855 'name' => \&_keep, 856 'version' => \&_keep, 857 # PRIOR OPTIONAL 858 'build_requires' => \&_version_map, 859 'conflicts' => \&_version_map, 860 'distribution_type' => \&_keep, 861 'dynamic_config' => \&_keep_or_one, 862 'keywords' => \&_keep, 863 'no_index' => \&_no_index_directory, 864 'optional_features' => \&_optional_features_1_4, 865 'provides' => \&_provides, 866 'recommends' => \&_version_map, 867 'requires' => \&_version_map, 868 'resources' => \&_resources_1_4, 869 # ADDED OPTIONAL 870 'configure_requires' => \&_keep, 871 872 # drop these deprecated fields, but only after we convert 873 ':drop' => [ qw( 874 license_url 875 private 876 )], 877 878 # other random keys are OK if already valid 879 ':custom' => \&_keep 880 }, 881 '1.3-from-1.2' => { 882 # PRIOR MANDATORY 883 'abstract' => \&_keep_or_unknown, 884 'author' => \&_author_list, 885 'generated_by' => \&_generated_by, 886 'license' => \&_license_1, 887 'meta-spec' => \&_change_meta_spec, 888 'name' => \&_keep, 889 'version' => \&_keep, 890 # PRIOR OPTIONAL 891 'build_requires' => \&_version_map, 892 'conflicts' => \&_version_map, 893 'distribution_type' => \&_keep, 894 'dynamic_config' => \&_keep_or_one, 895 'keywords' => \&_keep, 896 'no_index' => \&_no_index_directory, 897 'optional_features' => \&_optional_features_as_map, 898 'provides' => \&_provides, 899 'recommends' => \&_version_map, 900 'requires' => \&_version_map, 901 'resources' => \&_resources_1_3, 902 903 # drop these deprecated fields, but only after we convert 904 ':drop' => [ qw( 905 license_url 906 private 907 )], 908 909 # other random keys are OK if already valid 910 ':custom' => \&_keep 911 }, 912 '1.2-from-1.1' => { 913 # PRIOR MANDATORY 914 'version' => \&_keep, 915 # CHANGED TO MANDATORY 916 'license' => \&_license_1, 917 'name' => \&_keep, 918 'generated_by' => \&_generated_by, 919 # ADDED MANDATORY 920 'abstract' => \&_keep_or_unknown, 921 'author' => \&_author_list, 922 'meta-spec' => \&_change_meta_spec, 923 # PRIOR OPTIONAL 924 'build_requires' => \&_version_map, 925 'conflicts' => \&_version_map, 926 'distribution_type' => \&_keep, 927 'dynamic_config' => \&_keep_or_one, 928 'recommends' => \&_version_map, 929 'requires' => \&_version_map, 930 # ADDED OPTIONAL 931 'keywords' => \&_keep, 932 'no_index' => \&_no_index_1_2, 933 'optional_features' => \&_optional_features_as_map, 934 'provides' => \&_provides, 935 'resources' => \&_resources_1_2, 936 937 # drop these deprecated fields, but only after we convert 938 ':drop' => [ qw( 939 license_url 940 private 941 )], 942 943 # other random keys are OK if already valid 944 ':custom' => \&_keep 945 }, 946 '1.1-from-1.0' => { 947 # CHANGED TO MANDATORY 948 'version' => \&_keep, 949 # IMPLIED MANDATORY 950 'name' => \&_keep, 951 # PRIOR OPTIONAL 952 'build_requires' => \&_version_map, 953 'conflicts' => \&_version_map, 954 'distribution_type' => \&_keep, 955 'dynamic_config' => \&_keep_or_one, 956 'generated_by' => \&_generated_by, 957 'license' => \&_license_1, 958 'recommends' => \&_version_map, 959 'requires' => \&_version_map, 960 # ADDED OPTIONAL 961 'license_url' => \&_url_or_drop, 962 'private' => \&_keep, 963 964 # other random keys are OK if already valid 965 ':custom' => \&_keep 966 }, 967); 968 969my %down_convert = ( 970 '1.4-from-2' => { 971 # MANDATORY 972 'abstract' => \&_keep_or_unknown, 973 'author' => \&_author_list, 974 'generated_by' => \&_generated_by, 975 'license' => \&_downgrade_license, 976 'meta-spec' => \&_change_meta_spec, 977 'name' => \&_keep, 978 'version' => \&_keep, 979 # OPTIONAL 980 'build_requires' => \&_get_build_requires, 981 'configure_requires' => \&_get_configure_requires, 982 'conflicts' => \&_get_conflicts, 983 'distribution_type' => \&_keep, 984 'dynamic_config' => \&_keep_or_one, 985 'keywords' => \&_keep, 986 'no_index' => \&_no_index_directory, 987 'optional_features' => \&_downgrade_optional_features, 988 'provides' => \&_provides, 989 'recommends' => \&_get_recommends, 990 'requires' => \&_get_requires, 991 'resources' => \&_downgrade_resources, 992 993 # drop these unsupported fields (after conversion) 994 ':drop' => [ qw( 995 description 996 prereqs 997 release_status 998 )], 999 1000 # custom keys will be left unchanged 1001 ':custom' => \&_keep 1002 }, 1003 '1.3-from-1.4' => { 1004 # MANDATORY 1005 'abstract' => \&_keep_or_unknown, 1006 'author' => \&_author_list, 1007 'generated_by' => \&_generated_by, 1008 'license' => \&_license_1, 1009 'meta-spec' => \&_change_meta_spec, 1010 'name' => \&_keep, 1011 'version' => \&_keep, 1012 # OPTIONAL 1013 'build_requires' => \&_version_map, 1014 'conflicts' => \&_version_map, 1015 'distribution_type' => \&_keep, 1016 'dynamic_config' => \&_keep_or_one, 1017 'keywords' => \&_keep, 1018 'no_index' => \&_no_index_directory, 1019 'optional_features' => \&_optional_features_as_map, 1020 'provides' => \&_provides, 1021 'recommends' => \&_version_map, 1022 'requires' => \&_version_map, 1023 'resources' => \&_resources_1_3, 1024 1025 # drop these unsupported fields, but only after we convert 1026 ':drop' => [ qw( 1027 configure_requires 1028 )], 1029 1030 # other random keys are OK if already valid 1031 ':custom' => \&_keep, 1032 }, 1033 '1.2-from-1.3' => { 1034 # MANDATORY 1035 'abstract' => \&_keep_or_unknown, 1036 'author' => \&_author_list, 1037 'generated_by' => \&_generated_by, 1038 'license' => \&_license_1, 1039 'meta-spec' => \&_change_meta_spec, 1040 'name' => \&_keep, 1041 'version' => \&_keep, 1042 # OPTIONAL 1043 'build_requires' => \&_version_map, 1044 'conflicts' => \&_version_map, 1045 'distribution_type' => \&_keep, 1046 'dynamic_config' => \&_keep_or_one, 1047 'keywords' => \&_keep, 1048 'no_index' => \&_no_index_1_2, 1049 'optional_features' => \&_optional_features_as_map, 1050 'provides' => \&_provides, 1051 'recommends' => \&_version_map, 1052 'requires' => \&_version_map, 1053 'resources' => \&_resources_1_3, 1054 1055 # other random keys are OK if already valid 1056 ':custom' => \&_keep, 1057 }, 1058 '1.1-from-1.2' => { 1059 # MANDATORY 1060 'version' => \&_keep, 1061 # IMPLIED MANDATORY 1062 'name' => \&_keep, 1063 'meta-spec' => \&_change_meta_spec, 1064 # OPTIONAL 1065 'build_requires' => \&_version_map, 1066 'conflicts' => \&_version_map, 1067 'distribution_type' => \&_keep, 1068 'dynamic_config' => \&_keep_or_one, 1069 'generated_by' => \&_generated_by, 1070 'license' => \&_license_1, 1071 'private' => \&_keep, 1072 'recommends' => \&_version_map, 1073 'requires' => \&_version_map, 1074 1075 # drop unsupported fields 1076 ':drop' => [ qw( 1077 abstract 1078 author 1079 provides 1080 no_index 1081 keywords 1082 resources 1083 )], 1084 1085 # other random keys are OK if already valid 1086 ':custom' => \&_keep, 1087 }, 1088 '1.0-from-1.1' => { 1089 # IMPLIED MANDATORY 1090 'name' => \&_keep, 1091 'meta-spec' => \&_change_meta_spec, 1092 'version' => \&_keep, 1093 # PRIOR OPTIONAL 1094 'build_requires' => \&_version_map, 1095 'conflicts' => \&_version_map, 1096 'distribution_type' => \&_keep, 1097 'dynamic_config' => \&_keep_or_one, 1098 'generated_by' => \&_generated_by, 1099 'license' => \&_license_1, 1100 'recommends' => \&_version_map, 1101 'requires' => \&_version_map, 1102 1103 # other random keys are OK if already valid 1104 ':custom' => \&_keep, 1105 }, 1106); 1107 1108my %cleanup = ( 1109 '2' => { 1110 # PRIOR MANDATORY 1111 'abstract' => \&_keep_or_unknown, 1112 'author' => \&_author_list, 1113 'generated_by' => \&_generated_by, 1114 'license' => \&_license_2, 1115 'meta-spec' => \&_change_meta_spec, 1116 'name' => \&_keep, 1117 'version' => \&_keep, 1118 # CHANGED TO MANDATORY 1119 'dynamic_config' => \&_keep_or_one, 1120 # ADDED MANDATORY 1121 'release_status' => \&_release_status, 1122 # PRIOR OPTIONAL 1123 'keywords' => \&_keep, 1124 'no_index' => \&_no_index_directory, 1125 'optional_features' => \&_cleanup_optional_features_2, 1126 'provides' => \&_provides, 1127 'resources' => \&_cleanup_resources_2, 1128 # ADDED OPTIONAL 1129 'description' => \&_keep, 1130 'prereqs' => \&_cleanup_prereqs, 1131 1132 # drop these deprecated fields, but only after we convert 1133 ':drop' => [ qw( 1134 build_requires 1135 configure_requires 1136 conflicts 1137 distribution_type 1138 license_url 1139 private 1140 recommends 1141 requires 1142 ) ], 1143 1144 # other random keys need x_ prefixing 1145 ':custom' => \&_prefix_custom, 1146 }, 1147 '1.4' => { 1148 # PRIOR MANDATORY 1149 'abstract' => \&_keep_or_unknown, 1150 'author' => \&_author_list, 1151 'generated_by' => \&_generated_by, 1152 'license' => \&_license_1, 1153 'meta-spec' => \&_change_meta_spec, 1154 'name' => \&_keep, 1155 'version' => \&_keep, 1156 # PRIOR OPTIONAL 1157 'build_requires' => \&_version_map, 1158 'conflicts' => \&_version_map, 1159 'distribution_type' => \&_keep, 1160 'dynamic_config' => \&_keep_or_one, 1161 'keywords' => \&_keep, 1162 'no_index' => \&_no_index_directory, 1163 'optional_features' => \&_optional_features_1_4, 1164 'provides' => \&_provides, 1165 'recommends' => \&_version_map, 1166 'requires' => \&_version_map, 1167 'resources' => \&_resources_1_4, 1168 # ADDED OPTIONAL 1169 'configure_requires' => \&_keep, 1170 1171 # other random keys are OK if already valid 1172 ':custom' => \&_keep 1173 }, 1174 '1.3' => { 1175 # PRIOR MANDATORY 1176 'abstract' => \&_keep_or_unknown, 1177 'author' => \&_author_list, 1178 'generated_by' => \&_generated_by, 1179 'license' => \&_license_1, 1180 'meta-spec' => \&_change_meta_spec, 1181 'name' => \&_keep, 1182 'version' => \&_keep, 1183 # PRIOR OPTIONAL 1184 'build_requires' => \&_version_map, 1185 'conflicts' => \&_version_map, 1186 'distribution_type' => \&_keep, 1187 'dynamic_config' => \&_keep_or_one, 1188 'keywords' => \&_keep, 1189 'no_index' => \&_no_index_directory, 1190 'optional_features' => \&_optional_features_as_map, 1191 'provides' => \&_provides, 1192 'recommends' => \&_version_map, 1193 'requires' => \&_version_map, 1194 'resources' => \&_resources_1_3, 1195 1196 # other random keys are OK if already valid 1197 ':custom' => \&_keep 1198 }, 1199 '1.2' => { 1200 # PRIOR MANDATORY 1201 'version' => \&_keep, 1202 # CHANGED TO MANDATORY 1203 'license' => \&_license_1, 1204 'name' => \&_keep, 1205 'generated_by' => \&_generated_by, 1206 # ADDED MANDATORY 1207 'abstract' => \&_keep_or_unknown, 1208 'author' => \&_author_list, 1209 'meta-spec' => \&_change_meta_spec, 1210 # PRIOR OPTIONAL 1211 'build_requires' => \&_version_map, 1212 'conflicts' => \&_version_map, 1213 'distribution_type' => \&_keep, 1214 'dynamic_config' => \&_keep_or_one, 1215 'recommends' => \&_version_map, 1216 'requires' => \&_version_map, 1217 # ADDED OPTIONAL 1218 'keywords' => \&_keep, 1219 'no_index' => \&_no_index_1_2, 1220 'optional_features' => \&_optional_features_as_map, 1221 'provides' => \&_provides, 1222 'resources' => \&_resources_1_2, 1223 1224 # other random keys are OK if already valid 1225 ':custom' => \&_keep 1226 }, 1227 '1.1' => { 1228 # CHANGED TO MANDATORY 1229 'version' => \&_keep, 1230 # IMPLIED MANDATORY 1231 'name' => \&_keep, 1232 'meta-spec' => \&_change_meta_spec, 1233 # PRIOR OPTIONAL 1234 'build_requires' => \&_version_map, 1235 'conflicts' => \&_version_map, 1236 'distribution_type' => \&_keep, 1237 'dynamic_config' => \&_keep_or_one, 1238 'generated_by' => \&_generated_by, 1239 'license' => \&_license_1, 1240 'recommends' => \&_version_map, 1241 'requires' => \&_version_map, 1242 # ADDED OPTIONAL 1243 'license_url' => \&_url_or_drop, 1244 'private' => \&_keep, 1245 1246 # other random keys are OK if already valid 1247 ':custom' => \&_keep 1248 }, 1249 '1.0' => { 1250 # IMPLIED MANDATORY 1251 'name' => \&_keep, 1252 'meta-spec' => \&_change_meta_spec, 1253 'version' => \&_keep, 1254 # IMPLIED OPTIONAL 1255 'build_requires' => \&_version_map, 1256 'conflicts' => \&_version_map, 1257 'distribution_type' => \&_keep, 1258 'dynamic_config' => \&_keep_or_one, 1259 'generated_by' => \&_generated_by, 1260 'license' => \&_license_1, 1261 'recommends' => \&_version_map, 1262 'requires' => \&_version_map, 1263 1264 # other random keys are OK if already valid 1265 ':custom' => \&_keep, 1266 }, 1267); 1268 1269# for a given field in a spec version, what fields will it feed 1270# into in the *latest* spec (i.e. v2); meta-spec omitted because 1271# we always expect a meta-spec to be generated 1272my %fragments_generate = ( 1273 '2' => { 1274 'abstract' => 'abstract', 1275 'author' => 'author', 1276 'generated_by' => 'generated_by', 1277 'license' => 'license', 1278 'name' => 'name', 1279 'version' => 'version', 1280 'dynamic_config' => 'dynamic_config', 1281 'release_status' => 'release_status', 1282 'keywords' => 'keywords', 1283 'no_index' => 'no_index', 1284 'optional_features' => 'optional_features', 1285 'provides' => 'provides', 1286 'resources' => 'resources', 1287 'description' => 'description', 1288 'prereqs' => 'prereqs', 1289 }, 1290 '1.4' => { 1291 'abstract' => 'abstract', 1292 'author' => 'author', 1293 'generated_by' => 'generated_by', 1294 'license' => 'license', 1295 'name' => 'name', 1296 'version' => 'version', 1297 'build_requires' => 'prereqs', 1298 'conflicts' => 'prereqs', 1299 'distribution_type' => 'distribution_type', 1300 'dynamic_config' => 'dynamic_config', 1301 'keywords' => 'keywords', 1302 'no_index' => 'no_index', 1303 'optional_features' => 'optional_features', 1304 'provides' => 'provides', 1305 'recommends' => 'prereqs', 1306 'requires' => 'prereqs', 1307 'resources' => 'resources', 1308 'configure_requires' => 'prereqs', 1309 }, 1310); 1311# this is not quite true but will work well enough 1312# as 1.4 is a superset of earlier ones 1313$fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/; 1314 1315#--------------------------------------------------------------------------# 1316# Code 1317#--------------------------------------------------------------------------# 1318 1319#pod =method new 1320#pod 1321#pod my $cmc = CPAN::Meta::Converter->new( $struct ); 1322#pod 1323#pod The constructor should be passed a valid metadata structure but invalid 1324#pod structures are accepted. If no meta-spec version is provided, version 1.0 will 1325#pod be assumed. 1326#pod 1327#pod Optionally, you can provide a C<default_version> argument after C<$struct>: 1328#pod 1329#pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); 1330#pod 1331#pod This is only needed when converting a metadata fragment that does not include a 1332#pod C<meta-spec> field. 1333#pod 1334#pod =cut 1335 1336sub new { 1337 my ($class,$data,%args) = @_; 1338 1339 # create an attributes hash 1340 my $self = { 1341 'data' => $data, 1342 'spec' => _extract_spec_version($data, $args{default_version}), 1343 }; 1344 1345 # create the object 1346 return bless $self, $class; 1347} 1348 1349sub _extract_spec_version { 1350 my ($data, $default) = @_; 1351 my $spec = $data->{'meta-spec'}; 1352 1353 # is meta-spec there and valid? 1354 return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec? 1355 1356 # does the version key look like a valid version? 1357 my $v = $spec->{version}; 1358 if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) { 1359 return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec 1360 return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2 1361 } 1362 1363 # otherwise, use heuristics: look for 1.x vs 2.0 fields 1364 return "2" if exists $data->{prereqs}; 1365 return "1.4" if exists $data->{configure_requires}; 1366 return( $default || "1.2" ); # when meta-spec was first defined 1367} 1368 1369#pod =method convert 1370#pod 1371#pod my $new_struct = $cmc->convert( version => "2" ); 1372#pod 1373#pod Returns a new hash reference with the metadata converted to a different form. 1374#pod C<convert> will die if any conversion/standardization still results in an 1375#pod invalid structure. 1376#pod 1377#pod Valid parameters include: 1378#pod 1379#pod =over 1380#pod 1381#pod =item * 1382#pod 1383#pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). 1384#pod Defaults to the latest version of the CPAN Meta Spec. 1385#pod 1386#pod =back 1387#pod 1388#pod Conversion proceeds through each version in turn. For example, a version 1.2 1389#pod structure might be converted to 1.3 then 1.4 then finally to version 2. The 1390#pod conversion process attempts to clean-up simple errors and standardize data. 1391#pod For example, if C<author> is given as a scalar, it will converted to an array 1392#pod reference containing the item. (Converting a structure to its own version will 1393#pod also clean-up and standardize.) 1394#pod 1395#pod When data are cleaned and standardized, missing or invalid fields will be 1396#pod replaced with sensible defaults when possible. This may be lossy or imprecise. 1397#pod For example, some badly structured META.yml files on CPAN have prerequisite 1398#pod modules listed as both keys and values: 1399#pod 1400#pod requires => { 'Foo::Bar' => 'Bam::Baz' } 1401#pod 1402#pod These would be split and each converted to a prerequisite with a minimum 1403#pod version of zero. 1404#pod 1405#pod When some mandatory fields are missing or invalid, the conversion will attempt 1406#pod to provide a sensible default or will fill them with a value of 'unknown'. For 1407#pod example a missing or unrecognized C<license> field will result in a C<license> 1408#pod field of 'unknown'. Fields that may get an 'unknown' include: 1409#pod 1410#pod =for :list 1411#pod * abstract 1412#pod * author 1413#pod * license 1414#pod 1415#pod =cut 1416 1417sub convert { 1418 my ($self, %args) = @_; 1419 my $args = { %args }; 1420 1421 my $new_version = $args->{version} || $HIGHEST; 1422 my $is_fragment = $args->{is_fragment}; 1423 1424 my ($old_version) = $self->{spec}; 1425 my $converted = _dclone($self->{data}); 1426 1427 if ( $old_version == $new_version ) { 1428 $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment ); 1429 unless ( $args->{is_fragment} ) { 1430 my $cmv = CPAN::Meta::Validator->new( $converted ); 1431 unless ( $cmv->is_valid ) { 1432 my $errs = join("\n", $cmv->errors); 1433 die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; 1434 } 1435 } 1436 return $converted; 1437 } 1438 elsif ( $old_version > $new_version ) { 1439 my @vers = sort { $b <=> $a } keys %known_specs; 1440 for my $i ( 0 .. $#vers-1 ) { 1441 next if $vers[$i] > $old_version; 1442 last if $vers[$i+1] < $new_version; 1443 my $spec_string = "$vers[$i+1]-from-$vers[$i]"; 1444 $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment ); 1445 unless ( $args->{is_fragment} ) { 1446 my $cmv = CPAN::Meta::Validator->new( $converted ); 1447 unless ( $cmv->is_valid ) { 1448 my $errs = join("\n", $cmv->errors); 1449 die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; 1450 } 1451 } 1452 } 1453 return $converted; 1454 } 1455 else { 1456 my @vers = sort { $a <=> $b } keys %known_specs; 1457 for my $i ( 0 .. $#vers-1 ) { 1458 next if $vers[$i] < $old_version; 1459 last if $vers[$i+1] > $new_version; 1460 my $spec_string = "$vers[$i+1]-from-$vers[$i]"; 1461 $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment ); 1462 unless ( $args->{is_fragment} ) { 1463 my $cmv = CPAN::Meta::Validator->new( $converted ); 1464 unless ( $cmv->is_valid ) { 1465 my $errs = join("\n", $cmv->errors); 1466 die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; 1467 } 1468 } 1469 } 1470 return $converted; 1471 } 1472} 1473 1474#pod =method upgrade_fragment 1475#pod 1476#pod my $new_struct = $cmc->upgrade_fragment; 1477#pod 1478#pod Returns a new hash reference with the metadata converted to the latest version 1479#pod of the CPAN Meta Spec. No validation is done on the result -- you must 1480#pod validate after merging fragments into a complete metadata document. 1481#pod 1482#pod Available since version 2.141170. 1483#pod 1484#pod =cut 1485 1486sub upgrade_fragment { 1487 my ($self) = @_; 1488 my ($old_version) = $self->{spec}; 1489 my %expected = 1490 map {; $_ => 1 } 1491 grep { defined } 1492 map { $fragments_generate{$old_version}{$_} } 1493 keys %{ $self->{data} }; 1494 my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 ); 1495 for my $key ( keys %$converted ) { 1496 next if $key =~ /^x_/i || $key eq 'meta-spec'; 1497 delete $converted->{$key} unless $expected{$key}; 1498 } 1499 return $converted; 1500} 1501 15021; 1503 1504# ABSTRACT: Convert CPAN distribution metadata structures 1505 1506=pod 1507 1508=encoding UTF-8 1509 1510=head1 NAME 1511 1512CPAN::Meta::Converter - Convert CPAN distribution metadata structures 1513 1514=head1 VERSION 1515 1516version 2.150010 1517 1518=head1 SYNOPSIS 1519 1520 my $struct = decode_json_file('META.json'); 1521 1522 my $cmc = CPAN::Meta::Converter->new( $struct ); 1523 1524 my $new_struct = $cmc->convert( version => "2" ); 1525 1526=head1 DESCRIPTION 1527 1528This module converts CPAN Meta structures from one form to another. The 1529primary use is to convert older structures to the most modern version of 1530the specification, but other transformations may be implemented in the 1531future as needed. (E.g. stripping all custom fields or stripping all 1532optional fields.) 1533 1534=head1 METHODS 1535 1536=head2 new 1537 1538 my $cmc = CPAN::Meta::Converter->new( $struct ); 1539 1540The constructor should be passed a valid metadata structure but invalid 1541structures are accepted. If no meta-spec version is provided, version 1.0 will 1542be assumed. 1543 1544Optionally, you can provide a C<default_version> argument after C<$struct>: 1545 1546 my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); 1547 1548This is only needed when converting a metadata fragment that does not include a 1549C<meta-spec> field. 1550 1551=head2 convert 1552 1553 my $new_struct = $cmc->convert( version => "2" ); 1554 1555Returns a new hash reference with the metadata converted to a different form. 1556C<convert> will die if any conversion/standardization still results in an 1557invalid structure. 1558 1559Valid parameters include: 1560 1561=over 1562 1563=item * 1564 1565C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). 1566Defaults to the latest version of the CPAN Meta Spec. 1567 1568=back 1569 1570Conversion proceeds through each version in turn. For example, a version 1.2 1571structure might be converted to 1.3 then 1.4 then finally to version 2. The 1572conversion process attempts to clean-up simple errors and standardize data. 1573For example, if C<author> is given as a scalar, it will converted to an array 1574reference containing the item. (Converting a structure to its own version will 1575also clean-up and standardize.) 1576 1577When data are cleaned and standardized, missing or invalid fields will be 1578replaced with sensible defaults when possible. This may be lossy or imprecise. 1579For example, some badly structured META.yml files on CPAN have prerequisite 1580modules listed as both keys and values: 1581 1582 requires => { 'Foo::Bar' => 'Bam::Baz' } 1583 1584These would be split and each converted to a prerequisite with a minimum 1585version of zero. 1586 1587When some mandatory fields are missing or invalid, the conversion will attempt 1588to provide a sensible default or will fill them with a value of 'unknown'. For 1589example a missing or unrecognized C<license> field will result in a C<license> 1590field of 'unknown'. Fields that may get an 'unknown' include: 1591 1592=over 4 1593 1594=item * 1595 1596abstract 1597 1598=item * 1599 1600author 1601 1602=item * 1603 1604license 1605 1606=back 1607 1608=head2 upgrade_fragment 1609 1610 my $new_struct = $cmc->upgrade_fragment; 1611 1612Returns a new hash reference with the metadata converted to the latest version 1613of the CPAN Meta Spec. No validation is done on the result -- you must 1614validate after merging fragments into a complete metadata document. 1615 1616Available since version 2.141170. 1617 1618=head1 BUGS 1619 1620Please report any bugs or feature using the CPAN Request Tracker. 1621Bugs can be submitted through the web interface at 1622L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta> 1623 1624When submitting a bug or request, please include a test-file or a patch to an 1625existing test-file that illustrates the bug or desired feature. 1626 1627=head1 AUTHORS 1628 1629=over 4 1630 1631=item * 1632 1633David Golden <dagolden@cpan.org> 1634 1635=item * 1636 1637Ricardo Signes <rjbs@cpan.org> 1638 1639=item * 1640 1641Adam Kennedy <adamk@cpan.org> 1642 1643=back 1644 1645=head1 COPYRIGHT AND LICENSE 1646 1647This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors. 1648 1649This is free software; you can redistribute it and/or modify it under 1650the same terms as the Perl 5 programming language system itself. 1651 1652=cut 1653 1654__END__ 1655 1656 1657# vim: ts=2 sts=2 sw=2 et : 1658