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 13     13   13545 use 5.006;
  13         27  
2 13     13   43 use strict;
  13         14  
  13         203  
3 13     13   38 use warnings;
  13         15  
  13         587  
4             package CPAN::Meta::Converter;
5              
6             our $VERSION = '2.150009'; # TRIAL
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 13     13   5388 use CPAN::Meta::Validator;
  13         189  
  13         372  
27 13     13   533 use CPAN::Meta::Requirements;
  13         4163  
  13         845  
28 13     13   4417 use Parse::CPAN::Meta 1.4400 ();
  13         188  
  13         488  
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 13     13   596 eval "use version ()"; ## no critic
  13     13   52  
  13         15  
  13         114  
38 13 50       23619 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 1619     1619   6783 *_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 12472     12472   8724 my ( $ref ) = @_;
55 12472 100       27228 return $ref unless my $reftype = ref $ref;
56              
57 3798 100       4377 local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
58 3798 50       4354 die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
59              
60 3798 100       4399 return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
  918         869  
  509         527  
61 3289 100       3938 return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
  11249         12225  
  3277         5592  
62              
63 12 50       23 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 12 100       15 if ( eval { $ref->can('TO_JSON') } ) {
  12         76  
70 10         26 my $data = $ref->TO_JSON;
71 10 50       35 return ref $data ? _dclone( $data ) : $data;
72             }
73              
74             # Just stringify everything else
75 2         24 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 6364     6364   6931 sub _keep { $_[0] }
100              
101 544 100   544   1019 sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
102              
103 0 0   0   0 sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
104              
105 439 100 100 439   1538 sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
106              
107             sub _generated_by {
108 501     501   479 my $gen = shift;
109 501   50     3429 my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "");
110              
111 501 100 66     2169 return $sig unless defined $gen and length $gen;
112 496 100       2092 return $gen if $gen =~ /\Q$sig/;
113 209         555 return "$gen, $sig";
114             }
115              
116 800 100   800   1712 sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
    100          
117              
118             sub _prefix_custom {
119 133     133   130 my $key = shift;
120 133         403 $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 133         297 return $key;
124             }
125              
126             sub _ucfirst_custom {
127 6     6   6 my $key = shift;
128 6 50       16 $key = ucfirst $key unless $key =~ /[A-Z]/;
129 6         15 return $key;
130             }
131              
132             sub _no_prefix_ucfirst_custom {
133 6     6   5 my $key = shift;
134 6         19 $key =~ s/^x_//;
135 6         14 return _ucfirst_custom($key);
136             }
137              
138             sub _change_meta_spec {
139 519     519   668 my ($element, undef, undef, $version) = @_;
140             return {
141             version => $version,
142 519         1348 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   368 my ($element) = @_;
176 375 100       538 return 'unknown' unless defined $element;
177 351 50       774 if ( $license_map_1{lc $element} ) {
178 351         819 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 136     136   161 my ($element) = @_;
232 136 100       244 return [ 'unknown' ] unless defined $element;
233 116 100       276 $element = [ $element ] unless ref $element eq 'ARRAY';
234 116         125 my @new_list;
235 116         181 for my $lic ( @$element ) {
236 121 50       181 next unless defined $lic;
237 121 50       354 if ( my $new = $license_map_2{lc $lic} ) {
238 121         233 push @new_list, $new;
239             }
240             }
241 116 50       297 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   46 my ($element) = @_;
276 33 50       128 if ( ! defined $element ) {
    50          
    0          
277 0         0 return "unknown";
278             }
279             elsif( ref $element eq 'ARRAY' ) {
280 33 100       124 if ( @$element > 1) {
    50          
281 6 50 50     9 if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
  12         58  
282 0         0 return 'unknown';
283             }
284             else {
285 6         13 return 'open_source';
286             }
287             }
288             elsif ( @$element == 1 ) {
289 27   100     116 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   147 my (undef, undef, $meta) = @_;
322 94   66     260 my $no_index = $meta->{no_index} || $meta->{private};
323 94 100       194 return unless $no_index;
324              
325             # cleanup wrong format
326 21 50       65 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       36 if ( exists $no_index->{files} ) {
337 0         0 $no_index->{file} = delete $no_index->{files};
338             }
339             # common mistake: modules -> module
340 21 50       34 if ( exists $no_index->{modules} ) {
341 0         0 $no_index->{module} = delete $no_index->{modules};
342             }
343 21         35 return _convert($no_index, $no_index_spec_1_2);
344             }
345              
346             sub _no_index_directory {
347 345     345   526 my ($element, $key, $meta, $version) = @_;
348 345 100       602 return unless $element;
349              
350             # clean up wrong format
351 67 50       170 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         3 my $list = $element;
357 2         6 $element = { directory => [ @$list ], file => [ @$list ] };
358             }
359              
360 67 50       112 if ( exists $element->{dir} ) {
361 0         0 $element->{directory} = delete $element->{dir};
362             }
363             # common mistake: files -> file
364 67 50       101 if ( exists $element->{files} ) {
365 0         0 $element->{file} = delete $element->{files};
366             }
367             # common mistake: modules -> module
368 67 50       102 if ( exists $element->{modules} ) {
369 0         0 $element->{module} = delete $element->{modules};
370             }
371 67 100       113 my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
372 67         97 return _convert($element, $spec);
373             }
374              
375             sub _is_module_name {
376 12031     12031   10481 my $mod = shift;
377 12031 50 33     32676 return unless defined $mod && length $mod;
378 12031         35966 return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
379             }
380              
381             sub _clean_version {
382 1677     1677   1344 my ($element) = @_;
383 1677 100       2138 return 0 if ! defined $element;
384              
385 1619         3776 $element =~ s{^\s*}{};
386 1619         3769 $element =~ s{\s*$}{};
387 1619         1438 $element =~ s{^\.}{0.};
388              
389 1619 50       2479 return 0 if ! length $element;
390 1619 50 33     4411 return 0 if ( $element eq 'undef' || $element eq '' );
391              
392 1619         1320 my $v = eval { version->new($element) };
  1619         6309  
393             # XXX check defined $v and not just $v because version objects leak memory
394             # in boolean context -- dagolden, 2012-02-03
395 1619 50       1948 if ( defined $v ) {
396 1619 50       1670 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   2408 my ($v) = @_;
405 52         142 $v =~ s{^\s*}{};
406 52         142 $v =~ s{\s*$}{};
407 52         80 $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
408 52         40 my $vobj = eval { version->new($v) };
  52         221  
409 52 100       264 return defined($vobj) ? $vobj : version->new(0); # or give up
410             }
411              
412             sub _version_map {
413 2487     2487   2318 my ($element) = @_;
414 2487 100       3608 return unless defined $element;
415 1142 100 0     1603 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 1137         3632 my $new_map = CPAN::Meta::Requirements->new(
419             { bad_version_hook => \&_bad_version_hook } # punt
420             );
421 1137         11374 while ( my ($k,$v) = each %$element ) {
422 6018 100       227320 next unless _is_module_name($k);
423 6013 50 33     33339 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 6013 100 66     6017 if ( _is_module_name($v) && ! version::is_lax($v) ) {
429 12         267 $new_map->add_minimum($k => 0);
430 12         212 $new_map->add_minimum($v => 0);
431             }
432 6013         10615 $new_map->add_string_requirement($k => $v);
433             }
434 1137         59247 return $new_map->as_string_hash;
435             }
436             elsif ( ref $element eq 'ARRAY' ) {
437 5         8 my $hashref = { map { $_ => 0 } @$element };
  30         41  
438 5         16 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   116 my (undef, undef, $meta) = @_;
448 86         92 my $prereqs = {};
449 86         104 for my $phase ( qw/build configure/ ) {
450 172         1300 my $key = "${phase}_requires";
451             $prereqs->{$phase}{requires} = _version_map($meta->{$key})
452 172 100       370 if $meta->{$key};
453             }
454 86         303 for my $rel ( qw/requires recommends conflicts/ ) {
455             $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
456 258 100       5237 if $meta->{$rel};
457             }
458 86         155 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 85     85   104 my ($prereqs, $key, $meta, $to_version) = @_;
480 85 100 66     282 return unless $prereqs && ref $prereqs eq 'HASH';
481 63         111 return _convert( $prereqs, $prereqs_spec, $to_version );
482             }
483              
484             sub _prereqs_rel {
485 315     315   341 my ($relation, $key, $meta, $to_version) = @_;
486 315 100 66     707 return unless $relation && ref $relation eq 'HASH';
487 127         180 return _convert( $relation, $relation_spec, $to_version );
488             }
489              
490              
491             BEGIN {
492 13     13   31 my @old_prereqs = qw(
493             requires
494             configure_requires
495             recommends
496             conflicts
497             );
498              
499 13         26 for ( @old_prereqs ) {
500 52         69 my $sub = "_get_$_";
501 52         266 my ($phase,$type) = split qr/_/, $_;
502 52 100       144 if ( ! defined $type ) {
503 39         37 $type = $phase;
504 39         34 $phase = 'runtime';
505             }
506 13     13   61 no strict 'refs';
  13         10  
  13         776  
507 52     132   122 *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  52         47014  
  132         205  
508             }
509             }
510              
511             sub _get_build_requires {
512 33     33   64 my ($data, $key, $meta) = @_;
513              
514 33   100     88 my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
515 33   100     609 my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
516              
517 33         689 my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
518 33         3101 my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
519              
520 33         2598 $test_req->add_requirements($build_req)->as_string_hash;
521             }
522              
523             sub _extract_prereqs {
524 318     318   697 my ($prereqs, $phase, $type) = @_;
525 318 50       474 return unless ref $prereqs eq 'HASH';
526 318         575 return scalar _version_map($prereqs->{$phase}{$type});
527             }
528              
529             sub _downgrade_optional_features {
530 33     33   53 my (undef, undef, $meta) = @_;
531 33 100       78 return unless exists $meta->{optional_features};
532 24         37 my $origin = $meta->{optional_features};
533 24         37 my $features = {};
534 24         63 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         77 conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
542             };
543 24         61 for my $k (keys %{$features->{$name}} ) {
  24         79  
544 144 100       261 delete $features->{$name}{$k} unless defined $features->{$name}{$k};
545             }
546             }
547 24         38 return $features;
548             }
549              
550             sub _upgrade_optional_features {
551 76     76   119 my (undef, undef, $meta) = @_;
552 76 100       159 return unless exists $meta->{optional_features};
553 4         6 my $origin = $meta->{optional_features};
554 4         6 my $features = {};
555 4         11 for my $name ( keys %$origin ) {
556             $features->{$name} = {
557             description => $origin->{$name}{description},
558 10         25 prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
559             };
560 10         16 delete $features->{$name}{prereqs}{configure};
561             }
562 4         8 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   30 my ($element, $key, $meta, $to_version) = @_;
573 25 50 33     98 return unless $element && ref $element eq 'HASH';
574 25         40 _convert( $element, $optional_features_2_spec, $to_version );
575             }
576              
577             sub _cleanup_optional_features_2 {
578 60     60   82 my ($element, $key, $meta, $to_version) = @_;
579 60 100 66     185 return unless $element && ref $element eq 'HASH';
580 25         29 my $new_data = {};
581 25         48 for my $k ( keys %$element ) {
582 25         58 $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
583             }
584 25 50       59 return unless keys %$new_data;
585 25         28 return $new_data;
586             }
587              
588             sub _optional_features_1_4 {
589 71     71   101 my ($element) = @_;
590 71 100       131 return unless $element;
591 4         9 $element = _optional_features_as_map($element);
592 4         14 for my $name ( keys %$element ) {
593 12         14 for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
594 36         45 delete $element->{$name}{$drop};
595             }
596             }
597 4         7 return $element;
598             }
599              
600             sub _optional_features_as_map {
601 203     203   281 my ($element) = @_;
602 203 100       357 return unless $element;
603 48 100       102 if ( ref $element eq 'ARRAY' ) {
604 4         5 my %map;
605 4         6 for my $feature ( @$element ) {
606 12         21 my (@parts) = %$feature;
607 12         20 $map{$parts[0]} = $parts[1];
608             }
609 4         7 $element = \%map;
610             }
611 48         68 return $element;
612             }
613              
614 813 100   813   3382 sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
615              
616             sub _url_or_drop {
617 703     703   737 my ($element) = @_;
618 703 100       753 return $element if _is_urlish($element);
619 413         431 return;
620             }
621              
622             sub _url_list {
623 38     38   45 my ($element) = @_;
624 38 100       63 return unless $element;
625 30         55 $element = _listify( $element );
626 30         39 $element = [ grep { _is_urlish($_) } @$element ];
  30         45  
627 30 50       69 return unless @$element;
628 30         39 return $element;
629             }
630              
631             sub _author_list {
632 439     439   418 my ($element) = @_;
633 439 100       700 return [ 'unknown' ] unless $element;
634 383         544 $element = _listify( $element );
635 383 50 33     558 $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  575         2283  
636 383 50       656 return [ 'unknown' ] unless @$element;
637 383         392 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   124 my (undef, undef, $meta, $version) = @_;
656 76 100       149 return unless exists $meta->{resources};
657 37         91 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 21     21   40 my ($element, $key, $meta, $to_version) = @_;
668 21 100       44 return $element if defined $element;
669 18 100       40 return unless exists $meta->{url};
670 17         23 my $repo_url = $meta->{url};
671 17         27 for my $type ( qw/git svn/ ) {
672 33 100       413 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 60     60   76 my ($resources, $key, $meta, $to_version) = @_;
694 60 100 66     206 return unless $resources && ref $resources eq 'HASH';
695 38         80 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   335 my (undef, undef, $meta, $version) = @_;
708 239 100       414 return unless exists $meta->{resources};
709 129         215 return _convert($meta->{resources}, $resource1_spec);
710             }
711              
712             *_resources_1_4 = *_resources_1_3;
713              
714             sub _resources_1_2 {
715 31     31   50 my (undef, undef, $meta) = @_;
716 31   100     120 my $resources = $meta->{resources} || {};
717 31 100 66     81 if ( $meta->{license_url} && ! $resources->{license} ) {
718             $resources->{license} = $meta->{license_url}
719 1 50       3 if _is_urlish($meta->{license_url});
720             }
721 31 100       88 return unless keys %$resources;
722 2         7 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   61 my (undef, undef, $meta, $version) = @_;
735 33 100       80 return unless exists $meta->{resources};
736 27         67 return _convert($meta->{resources}, $resource_downgrade_spec);
737             }
738              
739             sub _release_status {
740 136     136   206 my ($element, undef, $meta) = @_;
741 136 100 66     434 return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
742 104         179 return _release_status_from_version(undef, undef, $meta);
743             }
744              
745             sub _release_status_from_version {
746 104     104   132 my (undef, undef, $meta) = @_;
747 104   100     246 my $version = $meta->{version} || '';
748 104 100       253 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 439     439   617 my ($element, $key, $meta, $to_version) = @_;
764 439 100 66     1097 return unless defined $element && ref $element eq 'HASH';
765 120 100       208 my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
766 120         132 my $new_data = {};
767 120         509 for my $k ( keys %$element ) {
768 1736         2586 $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
769             $new_data->{$k}{version} = _clean_version($element->{$k}{version})
770 1736 100       4020 if exists $element->{$k}{version};
771             }
772 120         255 return $new_data;
773             }
774              
775             sub _convert {
776 2847     2847   2983 my ($data, $spec, $to_version, $is_fragment) = @_;
777              
778 2847         2346 my $new_data = {};
779 2847         4999 for my $key ( keys %$spec ) {
780 16633 100 100     41757 next if $key eq ':custom' || $key eq ':drop';
781 14664 50       19200 next unless my $fcn = $spec->{$key};
782 14664 100 100     19308 if ( $is_fragment && $key eq 'generated_by' ) {
783 43         50 $fcn = \&_keep;
784             }
785 14664 50 33     36564 die "spec for '$key' is not a coderef"
786             unless ref $fcn && ref $fcn eq 'CODE';
787 14664         20696 my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
788 14664 100       67603 $new_data->{$key} = $new_value if defined $new_value;
789             }
790              
791 2847         3044 my $drop_list = $spec->{':drop'};
792 2847   100     5080 my $customizer = $spec->{':custom'} || \&_keep;
793              
794 2847         4976 for my $key ( keys %$data ) {
795 10729 100 100     13797 next if $drop_list && grep { $key eq $_ } @$drop_list;
  19732         21817  
796 10301 100       14342 next if exists $spec->{$key}; # we handled it
797 748         1170 $new_data->{ $customizer->($key) } = $data->{$key};
798             }
799              
800 2847         4693 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 250     250 1 15180 my ($class,$data,%args) = @_;
1338              
1339             # create an attributes hash
1340             my $self = {
1341             'data' => $data,
1342 250         660 'spec' => _extract_spec_version($data, $args{default_version}),
1343             };
1344              
1345             # create the object
1346 250         710 return bless $self, $class;
1347             }
1348              
1349             sub _extract_spec_version {
1350 494     494   18322 my ($data, $default) = @_;
1351 494         564 my $spec = $data->{'meta-spec'};
1352              
1353             # is meta-spec there and valid?
1354 494 100 100     2103 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 432         486 my $v = $spec->{version};
1358 432 100 66     2445 if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
1359 426 100 66     1253 return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
  2556         4466  
1360 16 100 66     56 return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
  96         244  
1361             }
1362              
1363             # otherwise, use heuristics: look for 1.x vs 2.0 fields
1364 11 100       36 return "2" if exists $data->{prereqs};
1365 6 50       14 return "1.4" if exists $data->{configure_requires};
1366 6   50     30 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 251     251 1 1270 my ($self, %args) = @_;
1419 251         481 my $args = { %args };
1420              
1421 251   33     555 my $new_version = $args->{version} || $HIGHEST;
1422 251         257 my $is_fragment = $args->{is_fragment};
1423              
1424 251         319 my ($old_version) = $self->{spec};
1425 251         492 my $converted = _dclone($self->{data});
1426              
1427 251 100       1240 if ( $old_version == $new_version ) {
    100          
1428 70         171 $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
1429 70 100       452 unless ( $args->{is_fragment} ) {
1430 39         175 my $cmv = CPAN::Meta::Validator->new( $converted );
1431 39 50       95 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 70         190 return $converted;
1437             }
1438             elsif ( $old_version > $new_version ) {
1439 81         401 my @vers = sort { $b <=> $a } keys %known_specs;
  842         963  
1440 81         251 for my $i ( 0 .. $#vers-1 ) {
1441 346 100       668 next if $vers[$i] > $old_version;
1442 266 100       537 last if $vers[$i+1] < $new_version;
1443 229         390 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1444 229         482 $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
1445 229 50       1773 unless ( $args->{is_fragment} ) {
1446 229         660 my $cmv = CPAN::Meta::Validator->new( $converted );
1447 229 100       427 unless ( $cmv->is_valid ) {
1448 5         10 my $errs = join("\n", $cmv->errors);
1449 5         66 die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1450             }
1451             }
1452             }
1453 76         364 return $converted;
1454             }
1455             else {
1456 100         421 my @vers = sort { $a <=> $b } keys %known_specs;
  1022         1107  
1457 100         266 for my $i ( 0 .. $#vers-1 ) {
1458 490 100       755 next if $vers[$i] < $old_version;
1459 265 100       482 last if $vers[$i+1] > $new_version;
1460 245         398 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1461 245         489 $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
1462 245 100       1426 unless ( $args->{is_fragment} ) {
1463 233         732 my $cmv = CPAN::Meta::Validator->new( $converted );
1464 233 100       546 unless ( $cmv->is_valid ) {
1465 5         10 my $errs = join("\n", $cmv->errors);
1466 5         66 die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1467             }
1468             }
1469             }
1470 95         359 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 46 my ($self) = @_;
1488 36         56 my ($old_version) = $self->{spec};
1489             my %expected =
1490 136         166 map {; $_ => 1 }
1491 156         144 grep { defined }
1492 156         169 map { $fragments_generate{$old_version}{$_} }
1493 36         31 keys %{ $self->{data} };
  36         87  
1494 36         80 my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
1495 36         76 for my $key ( keys %$converted ) {
1496 295 100 100     761 next if $key =~ /^x_/i || $key eq 'meta-spec';
1497 254 100       366 delete $converted->{$key} unless $expected{$key};
1498             }
1499 36         136 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.150009
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__