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   13860 use 5.006;
  13         27  
2 13     13   39 use strict;
  13         13  
  13         203  
3 13     13   36 use warnings;
  13         14  
  13         544  
4             package CPAN::Meta::Converter;
5              
6             our $VERSION = '2.150010';
7              
8             #pod =head1 SYNOPSIS
9             #pod
10             #pod my $struct = decode_json_file('META.json');
11             #pod
12             #pod my $cmc = CPAN::Meta::Converter->new( $struct );
13             #pod
14             #pod my $new_struct = $cmc->convert( version => "2" );
15             #pod
16             #pod =head1 DESCRIPTION
17             #pod
18             #pod This module converts CPAN Meta structures from one form to another. The
19             #pod primary use is to convert older structures to the most modern version of
20             #pod the specification, but other transformations may be implemented in the
21             #pod future as needed. (E.g. stripping all custom fields or stripping all
22             #pod optional fields.)
23             #pod
24             #pod =cut
25              
26 13     13   5404 use CPAN::Meta::Validator;
  13         181  
  13         337  
27 13     13   549 use CPAN::Meta::Requirements;
  13         4120  
  13         873  
28 13     13   4370 use Parse::CPAN::Meta 1.4400 ();
  13         180  
  13         450  
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   558 eval "use version ()"; ## no critic
  13     13   49  
  13         13  
  13         101  
38 13 50       24489 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   6642 *_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 12474     12474   8807 my ( $ref ) = @_;
55 12474 100       26437 return $ref unless my $reftype = ref $ref;
56              
57 3798 100       4323 local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
58 3798 50       4228 die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
59              
60 3798 100       4277 return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
  919         855  
  509         580  
61 3289 100       3767 return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
  11250         12073  
  3277         5344  
62              
63 12 50       25 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       12 if ( eval { $ref->can('TO_JSON') } ) {
  12         63  
70 10         21 my $data = $ref->TO_JSON;
71 10 50       34 return ref $data ? _dclone( $data ) : $data;
72             }
73              
74             # Just stringify everything else
75 2         29 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   6816 sub _keep { $_[0] }
100              
101 544 100   544   934 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   1556 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     3332 my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "");
110              
111 501 100 66     2214 return $sig unless defined $gen and length $gen;
112 496 100       2159 return $gen if $gen =~ /\Q$sig/;
113 209         534 return "$gen, $sig";
114             }
115              
116 800 100   800   1795 sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
    100          
117              
118             sub _prefix_custom {
119 134     134   126 my $key = shift;
120 134         421 $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 134         305 return $key;
124             }
125              
126             sub _ucfirst_custom {
127 6     6   7 my $key = shift;
128 6 50       14 $key = ucfirst $key unless $key =~ /[A-Z]/;
129 6         11 return $key;
130             }
131              
132             sub _no_prefix_ucfirst_custom {
133 6     6   6 my $key = shift;
134 6         16 $key =~ s/^x_//;
135 6         9 return _ucfirst_custom($key);
136             }
137              
138             sub _change_meta_spec {
139 519     519   666 my ($element, undef, undef, $version) = @_;
140             return {
141             version => $version,
142 519         1295 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   408 my ($element) = @_;
176 375 100       525 return 'unknown' unless defined $element;
177 351 50       806 if ( $license_map_1{lc $element} ) {
178 351         541 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   154 my ($element) = @_;
232 136 100       236 return [ 'unknown' ] unless defined $element;
233 116 100       285 $element = [ $element ] unless ref $element eq 'ARRAY';
234 116         114 my @new_list;
235 116         159 for my $lic ( @$element ) {
236 121 50       170 next unless defined $lic;
237 121 50       362 if ( my $new = $license_map_2{lc $lic} ) {
238 121         216 push @new_list, $new;
239             }
240             }
241 116 50       268 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   39 my ($element) = @_;
276 33 50       108 if ( ! defined $element ) {
    50          
    0          
277 0         0 return "unknown";
278             }
279             elsif( ref $element eq 'ARRAY' ) {
280 33 100       100 if ( @$element > 1) {
    50          
281 6 50 50     7 if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
  12         43  
282 0         0 return 'unknown';
283             }
284             else {
285 6         11 return 'open_source';
286             }
287             }
288             elsif ( @$element == 1 ) {
289 27   100     117 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   162 my (undef, undef, $meta) = @_;
322 94   66     271 my $no_index = $meta->{no_index} || $meta->{private};
323 94 100       169 return unless $no_index;
324              
325             # cleanup wrong format
326 21 50       68 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       48 if ( exists $no_index->{files} ) {
337 0         0 $no_index->{file} = delete $no_index->{files};
338             }
339             # common mistake: modules -> module
340 21 50       37 if ( exists $no_index->{modules} ) {
341 0         0 $no_index->{module} = delete $no_index->{modules};
342             }
343 21         43 return _convert($no_index, $no_index_spec_1_2);
344             }
345              
346             sub _no_index_directory {
347 345     345   482 my ($element, $key, $meta, $version) = @_;
348 345 100       644 return unless $element;
349              
350             # clean up wrong format
351 67 50       176 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         4 my $list = $element;
357 2         9 $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       116 if ( exists $element->{files} ) {
365 0         0 $element->{file} = delete $element->{files};
366             }
367             # common mistake: modules -> module
368 67 50       121 if ( exists $element->{modules} ) {
369 0         0 $element->{module} = delete $element->{modules};
370             }
371 67 100       120 my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
372 67         114 return _convert($element, $spec);
373             }
374              
375             sub _is_module_name {
376 12031     12031   10219 my $mod = shift;
377 12031 50 33     32056 return unless defined $mod && length $mod;
378 12031         36075 return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
379             }
380              
381             sub _clean_version {
382 1677     1677   1318 my ($element) = @_;
383 1677 100       2010 return 0 if ! defined $element;
384              
385 1619         3621 $element =~ s{^\s*}{};
386 1619         3506 $element =~ s{\s*$}{};
387 1619         1412 $element =~ s{^\.}{0.};
388              
389 1619 50       2362 return 0 if ! length $element;
390 1619 50 33     4261 return 0 if ( $element eq 'undef' || $element eq '' );
391              
392 1619         1132 my $v = eval { version->new($element) };
  1619         5988  
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       1926 if ( defined $v ) {
396 1619 50       1635 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   2531 my ($v) = @_;
405 52         156 $v =~ s{^\s*}{};
406 52         164 $v =~ s{\s*$}{};
407 52         83 $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
408 52         48 my $vobj = eval { version->new($v) };
  52         236  
409 52 100       279 return defined($vobj) ? $vobj : version->new(0); # or give up
410             }
411              
412             sub _version_map {
413 2487     2487   2446 my ($element) = @_;
414 2487 100       4057 return unless defined $element;
415 1142 100 0     1494 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         3699 my $new_map = CPAN::Meta::Requirements->new(
419             { bad_version_hook => \&_bad_version_hook } # punt
420             );
421 1137         11203 while ( my ($k,$v) = each %$element ) {
422 6018 100       225496 next unless _is_module_name($k);
423 6013 50 33     32735 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     6197 if ( _is_module_name($v) && ! version::is_lax($v) ) {
429 12         287 $new_map->add_minimum($k => 0);
430 12         235 $new_map->add_minimum($v => 0);
431             }
432 6013         10558 $new_map->add_string_requirement($k => $v);
433             }
434 1137         59317 return $new_map->as_string_hash;
435             }
436             elsif ( ref $element eq 'ARRAY' ) {
437 5         7 my $hashref = { map { $_ => 0 } @$element };
  30         42  
438 5         14 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   120 my (undef, undef, $meta) = @_;
448 86         109 my $prereqs = {};
449 86         115 for my $phase ( qw/build configure/ ) {
450 172         1357 my $key = "${phase}_requires";
451             $prereqs->{$phase}{requires} = _version_map($meta->{$key})
452 172 100       421 if $meta->{$key};
453             }
454 86         299 for my $rel ( qw/requires recommends conflicts/ ) {
455             $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
456 258 100       5398 if $meta->{$rel};
457             }
458 86         150 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   98 my ($prereqs, $key, $meta, $to_version) = @_;
480 85 100 66     239 return unless $prereqs && ref $prereqs eq 'HASH';
481 63         91 return _convert( $prereqs, $prereqs_spec, $to_version );
482             }
483              
484             sub _prereqs_rel {
485 315     315   333 my ($relation, $key, $meta, $to_version) = @_;
486 315 100 66     694 return unless $relation && ref $relation eq 'HASH';
487 127         187 return _convert( $relation, $relation_spec, $to_version );
488             }
489              
490              
491             BEGIN {
492 13     13   32 my @old_prereqs = qw(
493             requires
494             configure_requires
495             recommends
496             conflicts
497             );
498              
499 13         29 for ( @old_prereqs ) {
500 52         80 my $sub = "_get_$_";
501 52         247 my ($phase,$type) = split qr/_/, $_;
502 52 100       132 if ( ! defined $type ) {
503 39         36 $type = $phase;
504 39         51 $phase = 'runtime';
505             }
506 13     13   60 no strict 'refs';
  13         17  
  13         900  
507 52     132   110 *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  52         46628  
  132         217  
508             }
509             }
510              
511             sub _get_build_requires {
512 33     33   47 my ($data, $key, $meta) = @_;
513              
514 33   100     88 my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
515 33   100     543 my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
516              
517 33         666 my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
518 33         2842 my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
519              
520 33         2428 $test_req->add_requirements($build_req)->as_string_hash;
521             }
522              
523             sub _extract_prereqs {
524 318     318   637 my ($prereqs, $phase, $type) = @_;
525 318 50       446 return unless ref $prereqs eq 'HASH';
526 318         519 return scalar _version_map($prereqs->{$phase}{$type});
527             }
528              
529             sub _downgrade_optional_features {
530 33     33   56 my (undef, undef, $meta) = @_;
531 33 100       73 return unless exists $meta->{optional_features};
532 24         35 my $origin = $meta->{optional_features};
533 24         33 my $features = {};
534 24         61 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         69 conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
542             };
543 24         52 for my $k (keys %{$features->{$name}} ) {
  24         83  
544 144 100       257 delete $features->{$name}{$k} unless defined $features->{$name}{$k};
545             }
546             }
547 24         36 return $features;
548             }
549              
550             sub _upgrade_optional_features {
551 76     76   122 my (undef, undef, $meta) = @_;
552 76 100       180 return unless exists $meta->{optional_features};
553 4         9 my $origin = $meta->{optional_features};
554 4         7 my $features = {};
555 4         14 for my $name ( keys %$origin ) {
556             $features->{$name} = {
557             description => $origin->{$name}{description},
558 10         36 prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
559             };
560 10         23 delete $features->{$name}{prereqs}{configure};
561             }
562 4         7 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   26 my ($element, $key, $meta, $to_version) = @_;
573 25 50 33     84 return unless $element && ref $element eq 'HASH';
574 25         30 _convert( $element, $optional_features_2_spec, $to_version );
575             }
576              
577             sub _cleanup_optional_features_2 {
578 60     60   72 my ($element, $key, $meta, $to_version) = @_;
579 60 100 66     174 return unless $element && ref $element eq 'HASH';
580 25         23 my $new_data = {};
581 25         44 for my $k ( keys %$element ) {
582 25         44 $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
583             }
584 25 50       51 return unless keys %$new_data;
585 25         24 return $new_data;
586             }
587              
588             sub _optional_features_1_4 {
589 71     71   100 my ($element) = @_;
590 71 100       144 return unless $element;
591 4         9 $element = _optional_features_as_map($element);
592 4         14 for my $name ( keys %$element ) {
593 12         17 for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
594 36         45 delete $element->{$name}{$drop};
595             }
596             }
597 4         8 return $element;
598             }
599              
600             sub _optional_features_as_map {
601 203     203   269 my ($element) = @_;
602 203 100       320 return unless $element;
603 48 100       99 if ( ref $element eq 'ARRAY' ) {
604 4         7 my %map;
605 4         6 for my $feature ( @$element ) {
606 12         22 my (@parts) = %$feature;
607 12         21 $map{$parts[0]} = $parts[1];
608             }
609 4         7 $element = \%map;
610             }
611 48         60 return $element;
612             }
613              
614 813 100   813   3453 sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
615              
616             sub _url_or_drop {
617 703     703   796 my ($element) = @_;
618 703 100       734 return $element if _is_urlish($element);
619 413         420 return;
620             }
621              
622             sub _url_list {
623 38     38   47 my ($element) = @_;
624 38 100       66 return unless $element;
625 30         50 $element = _listify( $element );
626 30         42 $element = [ grep { _is_urlish($_) } @$element ];
  30         39  
627 30 50       54 return unless @$element;
628 30         34 return $element;
629             }
630              
631             sub _author_list {
632 439     439   423 my ($element) = @_;
633 439 100       669 return [ 'unknown' ] unless $element;
634 383         530 $element = _listify( $element );
635 383 50 33     511 $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  575         2231  
636 383 50       672 return [ 'unknown' ] unless @$element;
637 383         391 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   135 my (undef, undef, $meta, $version) = @_;
656 76 100       154 return unless exists $meta->{resources};
657 37         76 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   31 my ($element, $key, $meta, $to_version) = @_;
668 21 100       41 return $element if defined $element;
669 18 100       31 return unless exists $meta->{url};
670 17         21 my $repo_url = $meta->{url};
671 17         23 for my $type ( qw/git svn/ ) {
672 33 100       343 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   71 my ($resources, $key, $meta, $to_version) = @_;
694 60 100 66     185 return unless $resources && ref $resources eq 'HASH';
695 38         55 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   375 my (undef, undef, $meta, $version) = @_;
708 239 100       423 return unless exists $meta->{resources};
709 129         238 return _convert($meta->{resources}, $resource1_spec);
710             }
711              
712             *_resources_1_4 = *_resources_1_3;
713              
714             sub _resources_1_2 {
715 31     31   55 my (undef, undef, $meta) = @_;
716 31   100     117 my $resources = $meta->{resources} || {};
717 31 100 66     84 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         6 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   65 my (undef, undef, $meta, $version) = @_;
735 33 100       82 return unless exists $meta->{resources};
736 27         60 return _convert($meta->{resources}, $resource_downgrade_spec);
737             }
738              
739             sub _release_status {
740 136     136   219 my ($element, undef, $meta) = @_;
741 136 100 66     414 return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
742 104         182 return _release_status_from_version(undef, undef, $meta);
743             }
744              
745             sub _release_status_from_version {
746 104     104   112 my (undef, undef, $meta) = @_;
747 104   100     240 my $version = $meta->{version} || '';
748 104 100       332 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   635 my ($element, $key, $meta, $to_version) = @_;
764 439 100 66     1127 return unless defined $element && ref $element eq 'HASH';
765 120 100       208 my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
766 120         116 my $new_data = {};
767 120         484 for my $k ( keys %$element ) {
768 1736         2436 $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
769             $new_data->{$k}{version} = _clean_version($element->{$k}{version})
770 1736 100       3899 if exists $element->{$k}{version};
771             }
772 120         236 return $new_data;
773             }
774              
775             sub _convert {
776 2847     2847   2631 my ($data, $spec, $to_version, $is_fragment) = @_;
777              
778 2847         2216 my $new_data = {};
779 2847         5025 for my $key ( keys %$spec ) {
780 16633 100 100     41697 next if $key eq ':custom' || $key eq ':drop';
781 14664 50       19203 next unless my $fcn = $spec->{$key};
782 14664 100 100     20114 if ( $is_fragment && $key eq 'generated_by' ) {
783 43         55 $fcn = \&_keep;
784             }
785 14664 50 33     36756 die "spec for '$key' is not a coderef"
786             unless ref $fcn && ref $fcn eq 'CODE';
787 14664         20187 my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
788 14664 100       65992 $new_data->{$key} = $new_value if defined $new_value;
789             }
790              
791 2847         2959 my $drop_list = $spec->{':drop'};
792 2847   100     5037 my $customizer = $spec->{':custom'} || \&_keep;
793              
794 2847         5192 for my $key ( keys %$data ) {
795 10730 100 100     13660 next if $drop_list && grep { $key eq $_ } @$drop_list;
  19740         22104  
796 10302 100       13713 next if exists $spec->{$key}; # we handled it
797 749         1049 $new_data->{ $customizer->($key) } = $data->{$key};
798             }
799              
800 2847         4594 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 12048 my ($class,$data,%args) = @_;
1338              
1339             # create an attributes hash
1340             my $self = {
1341             'data' => $data,
1342 250         681 'spec' => _extract_spec_version($data, $args{default_version}),
1343             };
1344              
1345             # create the object
1346 250         682 return bless $self, $class;
1347             }
1348              
1349             sub _extract_spec_version {
1350 494     494   19720 my ($data, $default) = @_;
1351 494         578 my $spec = $data->{'meta-spec'};
1352              
1353             # is meta-spec there and valid?
1354 494 100 100     2133 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         540 my $v = $spec->{version};
1358 432 100 66     2667 if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
1359 426 100 66     1198 return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
  2556         4516  
1360 16 100 66     51 return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
  96         205  
1361             }
1362              
1363             # otherwise, use heuristics: look for 1.x vs 2.0 fields
1364 11 100       33 return "2" if exists $data->{prereqs};
1365 6 50       14 return "1.4" if exists $data->{configure_requires};
1366 6   50     32 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 1216 my ($self, %args) = @_;
1419 251         497 my $args = { %args };
1420              
1421 251   33     546 my $new_version = $args->{version} || $HIGHEST;
1422 251         254 my $is_fragment = $args->{is_fragment};
1423              
1424 251         331 my ($old_version) = $self->{spec};
1425 251         459 my $converted = _dclone($self->{data});
1426              
1427 251 100       1289 if ( $old_version == $new_version ) {
    100          
1428 70         154 $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
1429 70 100       471 unless ( $args->{is_fragment} ) {
1430 39         149 my $cmv = CPAN::Meta::Validator->new( $converted );
1431 39 50       79 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         186 return $converted;
1437             }
1438             elsif ( $old_version > $new_version ) {
1439 81         373 my @vers = sort { $b <=> $a } keys %known_specs;
  777         868  
1440 81         253 for my $i ( 0 .. $#vers-1 ) {
1441 346 100       602 next if $vers[$i] > $old_version;
1442 266 100       541 last if $vers[$i+1] < $new_version;
1443 229         417 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1444 229         545 $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
1445 229 50       1657 unless ( $args->{is_fragment} ) {
1446 229         666 my $cmv = CPAN::Meta::Validator->new( $converted );
1447 229 100       448 unless ( $cmv->is_valid ) {
1448 5         11 my $errs = join("\n", $cmv->errors);
1449 5         68 die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1450             }
1451             }
1452             }
1453 76         380 return $converted;
1454             }
1455             else {
1456 100         437 my @vers = sort { $a <=> $b } keys %known_specs;
  863         1008  
1457 100         275 for my $i ( 0 .. $#vers-1 ) {
1458 490 100       761 next if $vers[$i] < $old_version;
1459 265 100       502 last if $vers[$i+1] > $new_version;
1460 245         399 my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1461 245         526 $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
1462 245 100       1732 unless ( $args->{is_fragment} ) {
1463 233         756 my $cmv = CPAN::Meta::Validator->new( $converted );
1464 233 100       455 unless ( $cmv->is_valid ) {
1465 5         11 my $errs = join("\n", $cmv->errors);
1466 5         62 die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1467             }
1468             }
1469             }
1470 95         394 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 43 my ($self) = @_;
1488 36         44 my ($old_version) = $self->{spec};
1489             my %expected =
1490 136         154 map {; $_ => 1 }
1491 156         142 grep { defined }
1492 156         169 map { $fragments_generate{$old_version}{$_} }
1493 36         25 keys %{ $self->{data} };
  36         86  
1494 36         74 my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
1495 36         69 for my $key ( keys %$converted ) {
1496 295 100 100     768 next if $key =~ /^x_/i || $key eq 'meta-spec';
1497 254 100       347 delete $converted->{$key} unless $expected{$key};
1498             }
1499 36         131 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.150010
1517              
1518             =head1 SYNOPSIS
1519              
1520             my $struct = decode_json_file('META.json');
1521              
1522             my $cmc = CPAN::Meta::Converter->new( $struct );
1523              
1524             my $new_struct = $cmc->convert( version => "2" );
1525              
1526             =head1 DESCRIPTION
1527              
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__