File Coverage

blib/lib/CPAN/Meta/Converter.pm
Criterion Covered Total %
statement 352 379 92.8
branch 194 242 80.1
condition 70 109 64.2
subroutine 60 61 98.3
pod 3 3 100.0
total 679 794 85.5


line stmt bran cond sub pod time code
1 22     22   130490 use 5.008001;
  22         93  
2 22     22   138 use strict;
  22         54  
  22         721  
3 22     22   122 use warnings;
  22         42  
  22         2468  
4             package CPAN::Meta::Converter;
5              
6             our $VERSION = '2.150013';
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              
26 22     22   13975 use CPAN::Meta::Validator;
  22         98  
  22         1527  
27 22     22   841 use CPAN::Meta::Requirements;
  22         10335  
  22         880  
28 22     22   11285 use Parse::CPAN::Meta 1.4400 ();
  22         535  
  22         1654  
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              
36             BEGIN {
37 22     22   1951 eval "use version ()"; ## no critic
  22     22   204  
  22         53  
  22         329  
38 22 50       85104 if ( my $err = $@ ) {
39 0 0       0 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 1817     1817   11066 *_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.
50             our $DCLONE_MAXDEPTH = 1024;
51             our $_CLONE_DEPTH;
52              
53             sub _dclone {
54 21782     21782   37173 my ( $ref ) = @_;
55 21782 100       78469 return $ref unless my $reftype = ref $ref;
56              
57 5360 100       10693 local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
58 5360 50       10102 die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
59              
60 5360 100       15500 return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
  2725         4520  
  729         1650  
61 4631 100       9187 return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
  18686         36253  
  4597         15206  
62              
63 34 50       128 if ( 'SCALAR' eq $reftype ) {
64 0         0 my $new = _dclone(${$ref});
  0         0  
65 0         0 return \$new;
66             }
67              
68             # We can't know if TO_JSON gives us cloned data, so refs must recurse
69 34 100       84 if ( eval { $ref->can('TO_JSON') } ) {
  34         351  
70 32         125 my $data = $ref->TO_JSON;
71 32 50       197 return ref $data ? _dclone( $data ) : $data;
72             }
73              
74             # Just stringify everything else
75 2         66 return "$ref";
76             }
77              
78             my %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              
87             my @spec_list = sort { $a <=> $b } keys %known_specs;
88             my ($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              
99 6870     6870   15593 sub _keep { $_[0] }
100              
101 566 100   566   1981 sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
102              
103 0 0   0   0 sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
104              
105 461 100 100 461   2443 sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
106              
107             sub _generated_by {
108 523     523   1799 my $gen = shift;
109 523   50     6020 my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "");
110              
111 523 100 66     3326 return $sig unless defined $gen and length $gen;
112 518 100       4949 return $gen if $gen =~ /\Q$sig/;
113 231         826 return "$gen, $sig";
114             }
115              
116 910 100   910   3496 sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
    100          
117              
118             sub _prefix_custom {
119 246     246   498 my $key = shift;
120 246         1793 $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 246         960 return $key;
124             }
125              
126             sub _ucfirst_custom {
127 6     6   12 my $key = shift;
128 6 50       25 $key = ucfirst $key unless $key =~ /[A-Z]/;
129 6         23 return $key;
130             }
131              
132             sub _no_prefix_ucfirst_custom {
133 6     6   12 my $key = shift;
134 6         26 $key =~ s/^x_//;
135 6         19 return _ucfirst_custom($key);
136             }
137              
138             sub _change_meta_spec {
139 541     541   1847 my ($element, undef, undef, $version) = @_;
140             return {
141             version => $version,
142 541         3082 url => $known_specs{$version},
143             };
144             }
145              
146             my @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              
160             my %is_open_source = map {; $_ => 1 } @open_source;
161              
162             my @valid_licenses_1 = (
163             @open_source,
164             'unrestricted',
165             'restrictive',
166             'unknown',
167             );
168              
169             my %license_map_1 = (
170             ( map { $_ => $_ } @valid_licenses_1 ),
171             artistic2 => 'artistic_2',
172             );
173              
174             sub _license_1 {
175 375     375   875 my ($element) = @_;
176 375 100       986 return 'unknown' unless defined $element;
177 351 50       1450 if ( $license_map_1{lc $element} ) {
178 351         1047 return $license_map_1{lc $element};
179             }
180             else {
181 0         0 return 'unknown';
182             }
183             }
184              
185             my @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.
218             my %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              
230             sub _license_2 {
231 158     158   467 my ($element) = @_;
232 158 100       571 return [ 'unknown' ] unless defined $element;
233 138 100       1148 $element = [ $element ] unless ref $element eq 'ARRAY';
234 138         347 my @new_list;
235 138         443 for my $lic ( @$element ) {
236 143 50       467 next unless defined $lic;
237 143 50       810 if ( my $new = $license_map_2{lc $lic} ) {
238 143         535 push @new_list, $new;
239             }
240             }
241 138 50       656 return @new_list ? \@new_list : [ 'unknown' ];
242             }
243              
244             my %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              
274             sub _downgrade_license {
275 33     33   121 my ($element) = @_;
276 33 50       885 if ( ! defined $element ) {
    50          
    0          
277 0         0 return "unknown";
278             }
279             elsif( ref $element eq 'ARRAY' ) {
280 33 100       173 if ( @$element > 1) {
    50          
281 6 50 50     18 if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
  12         93  
282 0         0 return 'unknown';
283             }
284             else {
285 6         22 return 'open_source';
286             }
287             }
288             elsif ( @$element == 1 ) {
289 27   100     206 return $license_downgrade_map{lc $element->[0]} || "unknown";
290             }
291             }
292             elsif ( ! ref $element ) {
293 0   0     0 return $license_downgrade_map{lc $element} || "unknown";
294             }
295 0         0 return "unknown";
296             }
297              
298             my $no_index_spec_1_2 = {
299             'file' => \&_listify,
300             'dir' => \&_listify,
301             'package' => \&_listify,
302             'namespace' => \&_listify,
303             };
304              
305             my $no_index_spec_1_3 = {
306             'file' => \&_listify,
307             'directory' => \&_listify,
308             'package' => \&_listify,
309             'namespace' => \&_listify,
310             };
311              
312             my $no_index_spec_2 = {
313             'file' => \&_listify,
314             'directory' => \&_listify,
315             'package' => \&_listify,
316             'namespace' => \&_listify,
317             ':custom' => \&_prefix_custom,
318             };
319              
320             sub _no_index_1_2 {
321 94     94   293 my (undef, undef, $meta) = @_;
322 94   66     559 my $no_index = $meta->{no_index} || $meta->{private};
323 94 100       312 return unless $no_index;
324              
325             # cleanup wrong format
326 21 50       93 if ( ! ref $no_index ) {
    50          
327 0         0 my $item = $no_index;
328 0         0 $no_index = { dir => [ $item ], file => [ $item ] };
329             }
330             elsif ( ref $no_index eq 'ARRAY' ) {
331 0         0 my $list = $no_index;
332 0         0 $no_index = { dir => [ @$list ], file => [ @$list ] };
333             }
334              
335             # common mistake: files -> file
336 21 50       68 if ( exists $no_index->{files} ) {
337 0         0 $no_index->{file} = delete $no_index->{files};
338             }
339             # common mistake: modules -> module
340 21 50       76 if ( exists $no_index->{modules} ) {
341 0         0 $no_index->{module} = delete $no_index->{modules};
342             }
343 21         54 return _convert($no_index, $no_index_spec_1_2);
344             }
345              
346             sub _no_index_directory {
347 367     367   1189 my ($element, $key, $meta, $version) = @_;
348 367 100       1256 return unless $element;
349              
350             # clean up wrong format
351 89 50       417 if ( ! ref $element ) {
    100          
352 0         0 my $item = $element;
353 0         0 $element = { directory => [ $item ], file => [ $item ] };
354             }
355             elsif ( ref $element eq 'ARRAY' ) {
356 2         5 my $list = $element;
357 2         11 $element = { directory => [ @$list ], file => [ @$list ] };
358             }
359              
360 89 50       338 if ( exists $element->{dir} ) {
361 0         0 $element->{directory} = delete $element->{dir};
362             }
363             # common mistake: files -> file
364 89 50       343 if ( exists $element->{files} ) {
365 0         0 $element->{file} = delete $element->{files};
366             }
367             # common mistake: modules -> module
368 89 50       343 if ( exists $element->{modules} ) {
369 0         0 $element->{module} = delete $element->{modules};
370             }
371 89 100       313 my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
372 89         307 return _convert($element, $spec);
373             }
374              
375             sub _is_module_name {
376 16429     16429   28727 my $mod = shift;
377 16429 50 33     54447 return unless defined $mod && length $mod;
378 16429         75911 return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
379             }
380              
381             sub _clean_version {
382 1875     1875   3693 my ($element) = @_;
383 1875 100       3854 return 0 if ! defined $element;
384              
385 1817         7197 $element =~ s{^\s*}{};
386 1817         7913 $element =~ s{\s*$}{};
387 1817         3512 $element =~ s{^\.}{0.};
388              
389 1817 50       3904 return 0 if ! length $element;
390 1817 50 33     6320 return 0 if ( $element eq 'undef' || $element eq '' );
391              
392 1817         3008 my $v = eval { version->new($element) };
  1817         13266  
393             # XXX check defined $v and not just $v because version objects leak memory
394             # in boolean context -- dagolden, 2012-02-03
395 1817 50       3995 if ( defined $v ) {
396 1817 50       3855 return _is_qv($v) ? $v->normal : $element;
397             }
398             else {
399 0         0 return 0;
400             }
401             }
402              
403             sub _bad_version_hook {
404 52     52   6190 my ($v) = @_;
405 52         256 $v =~ s{^\s*}{};
406 52         279 $v =~ s{\s*$}{};
407 52         166 $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
408 52         91 my $vobj = eval { version->new($v) };
  52         976  
409 52 100       468 return defined($vobj) ? $vobj : version->new(0); # or give up
410             }
411              
412             sub _version_map {
413 2927     2927   6585 my ($element) = @_;
414 2927 100       7222 return unless defined $element;
415 1318 100 0     3181 if ( ref $element eq 'HASH' ) {
    50          
    0          
416             # XXX turn this into CPAN::Meta::Requirements with bad version hook
417             # and then turn it back into a hash
418 1313         8729 my $new_map = CPAN::Meta::Requirements->new(
419             { bad_version_hook => \&_bad_version_hook } # punt
420             );
421 1313         26435 while ( my ($k,$v) = each %$element ) {
422 8217 100       745206 next unless _is_module_name($k);
423 8212 50 33     50257 if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '' ) {
      33        
      33        
424 0         0 $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 8212 100 66     15561 if ( _is_module_name($v) && ! version::is_lax($v) ) {
429 12         497 $new_map->add_minimum($k => 0);
430 12         686 $new_map->add_minimum($v => 0);
431             }
432 8212         28616 $new_map->add_string_requirement($k => $v);
433             }
434 1313         155862 return $new_map->as_string_hash;
435             }
436             elsif ( ref $element eq 'ARRAY' ) {
437 5         13 my $hashref = { map { $_ => 0 } @$element };
  30         83  
438 5         23 return _version_map($hashref); # clean up any weird stuff
439             }
440             elsif ( ref $element eq '' && length $element ) {
441 0         0 return { $element => 0 }
442             }
443 0         0 return;
444             }
445              
446             sub _prereqs_from_1 {
447 86     86   223 my (undef, undef, $meta) = @_;
448 86         215 my $prereqs = {};
449 86         201 for my $phase ( qw/build configure/ ) {
450 172         5921 my $key = "${phase}_requires";
451             $prereqs->{$phase}{requires} = _version_map($meta->{$key})
452 172 100       634 if $meta->{$key};
453             }
454 86         923 for my $rel ( qw/requires recommends conflicts/ ) {
455             $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
456 258 100       29964 if $meta->{$rel};
457             }
458 86         351 return $prereqs;
459             }
460              
461             my $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              
470             my $relation_spec = {
471             requires => \&_version_map,
472             recommends => \&_version_map,
473             suggests => \&_version_map,
474             conflicts => \&_version_map,
475             ':custom' => \&_prefix_custom,
476             };
477              
478             sub _cleanup_prereqs {
479 107     107   319 my ($prereqs, $key, $meta, $to_version) = @_;
480 107 100 66     523 return unless $prereqs && ref $prereqs eq 'HASH';
481 85         406 return _convert( $prereqs, $prereqs_spec, $to_version );
482             }
483              
484             sub _prereqs_rel {
485 425     425   1167 my ($relation, $key, $meta, $to_version) = @_;
486 425 100 66     1614 return unless $relation && ref $relation eq 'HASH';
487 237         790 return _convert( $relation, $relation_spec, $to_version );
488             }
489              
490              
491             BEGIN {
492 22     22   123 my @old_prereqs = qw(
493             requires
494             configure_requires
495             recommends
496             conflicts
497             );
498              
499 22         67 for ( @old_prereqs ) {
500 88         198 my $sub = "_get_$_";
501 88         768 my ($phase,$type) = split qr/_/, $_;
502 88 100       2764 if ( ! defined $type ) {
503 66         121 $type = $phase;
504 66         2218 $phase = 'runtime';
505             }
506 22     22   223 no strict 'refs';
  22         47  
  22         2896  
507 88     132   387 *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  88         188503  
  132         446  
508             }
509             }
510              
511             sub _get_build_requires {
512 33     33   121 my ($data, $key, $meta) = @_;
513              
514 33   100     114 my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
515 33   100     2619 my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
516              
517 33         2770 my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
518 33         7011 my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
519              
520 33         6000 $test_req->add_requirements($build_req)->as_string_hash;
521             }
522              
523             sub _extract_prereqs {
524 318     318   2070 my ($prereqs, $phase, $type) = @_;
525 318 50       726 return unless ref $prereqs eq 'HASH';
526 318         989 return scalar _version_map($prereqs->{$phase}{$type});
527             }
528              
529             sub _downgrade_optional_features {
530 33     33   109 my (undef, undef, $meta) = @_;
531 33 100       153 return unless exists $meta->{optional_features};
532 24         65 my $origin = $meta->{optional_features};
533 24         49 my $features = {};
534 24         232 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 24         117 conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
542             };
543 24         95 for my $k (keys %{$features->{$name}} ) {
  24         111  
544 144 100       378 delete $features->{$name}{$k} unless defined $features->{$name}{$k};
545             }
546             }
547 24         69 return $features;
548             }
549              
550             sub _upgrade_optional_features {
551 76     76   215 my (undef, undef, $meta) = @_;
552 76 100       328 return unless exists $meta->{optional_features};
553 4         12 my $origin = $meta->{optional_features};
554 4         9 my $features = {};
555 4         20 for my $name ( keys %$origin ) {
556             $features->{$name} = {
557             description => $origin->{$name}{description},
558 10         41 prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
559             };
560 10         30 delete $features->{$name}{prereqs}{configure};
561             }
562 4         15 return $features;
563             }
564              
565             my $optional_features_2_spec = {
566             description => \&_keep,
567             prereqs => \&_cleanup_prereqs,
568             ':custom' => \&_prefix_custom,
569             };
570              
571             sub _feature_2 {
572 25     25   67 my ($element, $key, $meta, $to_version) = @_;
573 25 50 33     118 return unless $element && ref $element eq 'HASH';
574 25         70 _convert( $element, $optional_features_2_spec, $to_version );
575             }
576              
577             sub _cleanup_optional_features_2 {
578 82     82   357 my ($element, $key, $meta, $to_version) = @_;
579 82 100 66     549 return unless $element && ref $element eq 'HASH';
580 25         50 my $new_data = {};
581 25         82 for my $k ( keys %$element ) {
582 25         87 $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
583             }
584 25 50       136 return unless keys %$new_data;
585 25         63 return $new_data;
586             }
587              
588             sub _optional_features_1_4 {
589 71     71   271 my ($element) = @_;
590 71 100       239 return unless $element;
591 4         16 $element = _optional_features_as_map($element);
592 4         20 for my $name ( keys %$element ) {
593 12         43 for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
594 36         100 delete $element->{$name}{$drop};
595             }
596             }
597 4         12 return $element;
598             }
599              
600             sub _optional_features_as_map {
601 203     203   648 my ($element) = @_;
602 203 100       679 return unless $element;
603 48 100       163 if ( ref $element eq 'ARRAY' ) {
604 4         9 my %map;
605 4         11 for my $feature ( @$element ) {
606 12         38 my (@parts) = %$feature;
607 12         34 $map{$parts[0]} = $parts[1];
608             }
609 4         11 $element = \%map;
610             }
611 48         114 return $element;
612             }
613              
614 901 100   901   5708 sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
615              
616             sub _url_or_drop {
617 791     791   1979 my ($element) = @_;
618 791 100       1706 return $element if _is_urlish($element);
619 413         863 return;
620             }
621              
622             sub _url_list {
623 60     60   235 my ($element) = @_;
624 60 100       254 return unless $element;
625 30         108 $element = _listify( $element );
626 30         91 $element = [ grep { _is_urlish($_) } @$element ];
  30         74  
627 30 50       111 return unless @$element;
628 30         66 return $element;
629             }
630              
631             sub _author_list {
632 461     461   1186 my ($element) = @_;
633 461 100       1409 return [ 'unknown' ] unless $element;
634 405         1193 $element = _listify( $element );
635 405 50 33     1110 $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  641         3368  
636 405 50       1268 return [ 'unknown' ] unless @$element;
637 405         977 return $element;
638             }
639              
640             my $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              
654             sub _upgrade_resources_2 {
655 76     76   238 my (undef, undef, $meta, $version) = @_;
656 76 100       365 return unless exists $meta->{resources};
657 37         144 return _convert($meta->{resources}, $resource2_upgrade);
658             }
659              
660             my $bugtracker2_spec = {
661             web => \&_url_or_drop,
662             mailto => \&_keep,
663             ':custom' => \&_prefix_custom,
664             };
665              
666             sub _repo_type {
667 43     43   252 my ($element, $key, $meta, $to_version) = @_;
668 43 100       222 return $element if defined $element;
669 18 100       72 return unless exists $meta->{url};
670 17         138 my $repo_url = $meta->{url};
671 17         41 for my $type ( qw/git svn/ ) {
672 33 100       700 return $type if $repo_url =~ m{\A$type};
673             }
674 1         2 return;
675             }
676              
677             my $repository2_spec = {
678             web => \&_url_or_drop,
679             url => \&_url_or_drop,
680             type => \&_repo_type,
681             ':custom' => \&_prefix_custom,
682             };
683              
684             my $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              
692             sub _cleanup_resources_2 {
693 82     82   300 my ($resources, $key, $meta, $to_version) = @_;
694 82 100 66     502 return unless $resources && ref $resources eq 'HASH';
695 60         272 return _convert($resources, $resources2_cleanup, $to_version);
696             }
697              
698             my $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              
706             sub _resources_1_3 {
707 239     239   684 my (undef, undef, $meta, $version) = @_;
708 239 100       853 return unless exists $meta->{resources};
709 129         421 return _convert($meta->{resources}, $resource1_spec);
710             }
711              
712             *_resources_1_4 = *_resources_1_3;
713              
714             sub _resources_1_2 {
715 31     31   94 my (undef, undef, $meta) = @_;
716 31   100     165 my $resources = $meta->{resources} || {};
717 31 100 66     152 if ( $meta->{license_url} && ! $resources->{license} ) {
718             $resources->{license} = $meta->{license_url}
719 1 50       4 if _is_urlish($meta->{license_url});
720             }
721 31 100       153 return unless keys %$resources;
722 2         9 return _convert($resources, $resource1_spec);
723             }
724              
725             my $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              
733             sub _downgrade_resources {
734 33     33   114 my (undef, undef, $meta, $version) = @_;
735 33 100       125 return unless exists $meta->{resources};
736 27         104 return _convert($meta->{resources}, $resource_downgrade_spec);
737             }
738              
739             sub _release_status {
740 158     158   586 my ($element, undef, $meta) = @_;
741 158 100 66     985 return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
742 104         345 return _release_status_from_version(undef, undef, $meta);
743             }
744              
745             sub _release_status_from_version {
746 104     104   244 my (undef, undef, $meta) = @_;
747 104   100     393 my $version = $meta->{version} || '';
748 104 100       487 return ( $version =~ /_/ ) ? 'testing' : 'stable';
749             }
750              
751             my $provides_spec = {
752             file => \&_keep,
753             version => \&_keep,
754             };
755              
756             my $provides_spec_2 = {
757             file => \&_keep,
758             version => \&_keep,
759             ':custom' => \&_prefix_custom,
760             };
761              
762             sub _provides {
763 461     461   1609 my ($element, $key, $meta, $to_version) = @_;
764 461 100 66     2841 return unless defined $element && ref $element eq 'HASH';
765 142 100       467 my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
766 142         324 my $new_data = {};
767 142         1099 for my $k ( keys %$element ) {
768 1934         5091 $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
769             $new_data->{$k}{version} = _clean_version($element->{$k}{version})
770 1934 100       6630 if exists $element->{$k}{version};
771             }
772 142         670 return $new_data;
773             }
774              
775             sub _convert {
776 3287     3287   7613 my ($data, $spec, $to_version, $is_fragment) = @_;
777              
778 3287         5255 my $new_data = {};
779 3287         10775 for my $key ( keys %$spec ) {
780 18679 100 100     60762 next if $key eq ':custom' || $key eq ':drop';
781 16248 50       38801 next unless my $fcn = $spec->{$key};
782 16248 100 100     34349 if ( $is_fragment && $key eq 'generated_by' ) {
783 43         91 $fcn = \&_keep;
784             }
785 16248 50 33     53484 die "spec for '$key' is not a coderef"
786             unless ref $fcn && ref $fcn eq 'CODE';
787 16248         42514 my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
788 16248 100       358465 $new_data->{$key} = $new_value if defined $new_value;
789             }
790              
791 3287         7702 my $drop_list = $spec->{':drop'};
792 3287   100     9460 my $customizer = $spec->{':custom'} || \&_keep;
793              
794 3287         9846 for my $key ( keys %$data ) {
795 12008 100 100     25210 next if $drop_list && grep { $key eq $_ } @$drop_list;
  22924         45143  
796 11580 100       25630 next if exists $spec->{$key}; # we handled it
797 861         2109 $new_data->{ $customizer->($key) } = $data->{$key};
798             }
799              
800 3287         16705 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
809             my %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              
969             my %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              
1108             my %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
1272             my %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 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 field.
1333             #pod
1334             #pod =cut
1335              
1336             sub new {
1337 272     272 1 26878 my ($class,$data,%args) = @_;
1338              
1339             # create an attributes hash
1340             my $self = {
1341             'data' => $data,
1342 272         1377 'spec' => _extract_spec_version($data, $args{default_version}),
1343             };
1344              
1345             # create the object
1346 272         2541 return bless $self, $class;
1347             }
1348              
1349             sub _extract_spec_version {
1350 516     516   30976 my ($data, $default) = @_;
1351 516         1447 my $spec = $data->{'meta-spec'};
1352              
1353             # is meta-spec there and valid?
1354 516 100 100     9229 return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
      100        
1355              
1356             # does the version key look like a valid version?
1357 454         1185 my $v = $spec->{version};
1358 454 100 66     4303 if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
1359 448 100 66     2647 return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
  2688         8146  
1360 16 100 66     116 return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
  96         368  
1361             }
1362              
1363             # otherwise, use heuristics: look for 1.x vs 2.0 fields
1364 11 100       194 return "2" if exists $data->{prereqs};
1365 6 50       27 return "1.4" if exists $data->{configure_requires};
1366 6   50     46 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 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 -- 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 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 field will result in a C
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              
1417             sub convert {
1418 273     273 1 2559 my ($self, %args) = @_;
1419 273         982 my $args = { %args };
1420              
1421 273   33     1092 my $new_version = $args->{version} || $HIGHEST;
1422 273         668 my $is_fragment = $args->{is_fragment};
1423              
1424 273         912 my ($old_version) = $self->{spec};
1425 273         1078 my $converted = _dclone($self->{data});
1426              
1427 273 100       2393 if ( $old_version == $new_version ) {
    100          
1428 92         549 $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
1429 92 100       393 unless ( $args->{is_fragment} ) {
1430 61         656 my $cmv = CPAN::Meta::Validator->new( $converted );
1431 61 50       299 unless ( $cmv->is_valid ) {
1432 0         0 my $errs = join("\n", $cmv->errors);
1433 0         0 die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
1434             }
1435             }
1436 92         581 return $converted;
1437             }
1438             elsif ( $old_version > $new_version ) {
1439 81         619 my @vers = sort { $b <=> $a } keys %known_specs;
  800         1967  
1440 81         406 for my $i ( 0 .. $#vers-1 ) {
1441 346 100       1262 next if $vers[$i] > $old_version;
1442 266 100       968 last if $vers[$i+1] < $new_version;
1443 229         671 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1444 229         1068 $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
1445 229 50       927 unless ( $args->{is_fragment} ) {
1446 229         1284 my $cmv = CPAN::Meta::Validator->new( $converted );
1447 229 100       782 unless ( $cmv->is_valid ) {
1448 5         19 my $errs = join("\n", $cmv->errors);
1449 5         129 die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1450             }
1451             }
1452             }
1453 76         721 return $converted;
1454             }
1455             else {
1456 100         796 my @vers = sort { $a <=> $b } keys %known_specs;
  1093         2627  
1457 100         475 for my $i ( 0 .. $#vers-1 ) {
1458 490 100       1476 next if $vers[$i] < $old_version;
1459 265 100       803 last if $vers[$i+1] > $new_version;
1460 245         666 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1461 245         1059 $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
1462 245 100       866 unless ( $args->{is_fragment} ) {
1463 233         1416 my $cmv = CPAN::Meta::Validator->new( $converted );
1464 233 100       784 unless ( $cmv->is_valid ) {
1465 5         46 my $errs = join("\n", $cmv->errors);
1466 5         128 die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1467             }
1468             }
1469             }
1470 95         726 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              
1486             sub upgrade_fragment {
1487 36     36 1 92 my ($self) = @_;
1488 36         81 my ($old_version) = $self->{spec};
1489             my %expected =
1490 136         298 map {; $_ => 1 }
1491 156         306 grep { defined }
1492 156         356 map { $fragments_generate{$old_version}{$_} }
1493 36         66 keys %{ $self->{data} };
  36         124  
1494 36         132 my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
1495 36         120 for my $key ( keys %$converted ) {
1496 295 100 100     956 next if $key =~ /^x_/i || $key eq 'meta-spec';
1497 254 100       636 delete $converted->{$key} unless $expected{$key};
1498             }
1499 36         199 return $converted;
1500             }
1501              
1502             1;
1503              
1504             # ABSTRACT: Convert CPAN distribution metadata structures
1505              
1506             =pod
1507              
1508             =encoding UTF-8
1509              
1510             =head1 NAME
1511              
1512             CPAN::Meta::Converter - Convert CPAN distribution metadata structures
1513              
1514             =head1 VERSION
1515              
1516             version 2.150013
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              
1528             This module converts CPAN Meta structures from one form to another. The
1529             primary use is to convert older structures to the most modern version of
1530             the specification, but other transformations may be implemented in the
1531             future as needed. (E.g. stripping all custom fields or stripping all
1532             optional fields.)
1533              
1534             =head1 METHODS
1535              
1536             =head2 new
1537              
1538             my $cmc = CPAN::Meta::Converter->new( $struct );
1539              
1540             The constructor should be passed a valid metadata structure but invalid
1541             structures are accepted. If no meta-spec version is provided, version 1.0 will
1542             be assumed.
1543              
1544             Optionally, you can provide a C argument after C<$struct>:
1545              
1546             my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
1547              
1548             This is only needed when converting a metadata fragment that does not include a
1549             C field.
1550              
1551             =head2 convert
1552              
1553             my $new_struct = $cmc->convert( version => "2" );
1554              
1555             Returns a new hash reference with the metadata converted to a different form.
1556             C will die if any conversion/standardization still results in an
1557             invalid structure.
1558              
1559             Valid parameters include:
1560              
1561             =over
1562              
1563             =item *
1564              
1565             C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
1566             Defaults to the latest version of the CPAN Meta Spec.
1567              
1568             =back
1569              
1570             Conversion proceeds through each version in turn. For example, a version 1.2
1571             structure might be converted to 1.3 then 1.4 then finally to version 2. The
1572             conversion process attempts to clean-up simple errors and standardize data.
1573             For example, if C is given as a scalar, it will converted to an array
1574             reference containing the item. (Converting a structure to its own version will
1575             also clean-up and standardize.)
1576              
1577             When data are cleaned and standardized, missing or invalid fields will be
1578             replaced with sensible defaults when possible. This may be lossy or imprecise.
1579             For example, some badly structured META.yml files on CPAN have prerequisite
1580             modules listed as both keys and values:
1581              
1582             requires => { 'Foo::Bar' => 'Bam::Baz' }
1583              
1584             These would be split and each converted to a prerequisite with a minimum
1585             version of zero.
1586              
1587             When some mandatory fields are missing or invalid, the conversion will attempt
1588             to provide a sensible default or will fill them with a value of 'unknown'. For
1589             example a missing or unrecognized C field will result in a C
1590             field of 'unknown'. Fields that may get an 'unknown' include:
1591              
1592             =over 4
1593              
1594             =item *
1595              
1596             abstract
1597              
1598             =item *
1599              
1600             author
1601              
1602             =item *
1603              
1604             license
1605              
1606             =back
1607              
1608             =head2 upgrade_fragment
1609              
1610             my $new_struct = $cmc->upgrade_fragment;
1611              
1612             Returns a new hash reference with the metadata converted to the latest version
1613             of the CPAN Meta Spec. No validation is done on the result -- you must
1614             validate after merging fragments into a complete metadata document.
1615              
1616             Available since version 2.141170.
1617              
1618             =head1 BUGS
1619              
1620             Please report any bugs or feature using the CPAN Request Tracker.
1621             Bugs can be submitted through the web interface at
1622             L
1623              
1624             When submitting a bug or request, please include a test-file or a patch to an
1625             existing test-file that illustrates the bug or desired feature.
1626              
1627             =head1 AUTHORS
1628              
1629             =over 4
1630              
1631             =item *
1632              
1633             David Golden
1634              
1635             =item *
1636              
1637             Ricardo Signes
1638              
1639             =item *
1640              
1641             Adam Kennedy
1642              
1643             =back
1644              
1645             =head1 COPYRIGHT AND LICENSE
1646              
1647             This software is copyright (c) 2010 by David Golden, Ricardo Signes, Adam Kennedy and Contributors.
1648              
1649             This is free software; you can redistribute it and/or modify it under
1650             the same terms as the Perl 5 programming language system itself.
1651              
1652             =cut
1653              
1654             __END__