Profile of CPAN/Meta/Converter.pm

← Index
NYTProf Performance Profile «line view»
For test.pl
Run on Mon Apr 5 14:31:27 2021
Reported on Mon Apr 5 14:31:40 2021

Filename | /home/leont/perl5/perlbrew/perls/perl-5.32.0/lib/5.32.0/CPAN/Meta/Converter.pm
Statements | Executed 75 statements in 4.00ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 2.38ms | 2.40ms | CPAN::Meta::Converter::::BEGIN@26CPAN::Meta::Converter::BEGIN@26
1 | 1 | 1 | 564µs | 623µs | CPAN::Meta::Converter::::BEGIN@28CPAN::Meta::Converter::BEGIN@28
1 | 1 | 1 | 25µs | 31µs | CPAN::Meta::Converter::::BEGIN@491CPAN::Meta::Converter::BEGIN@491
1 | 1 | 1 | 16µs | 19µs | CPAN::Meta::Converter::::BEGIN@36CPAN::Meta::Converter::BEGIN@36
1 | 1 | 1 | 9µs | 9µs | CPAN::Meta::Converter::::CORE:sortCPAN::Meta::Converter::CORE:sort (opcode)
1 | 1 | 1 | 7µs | 7µs | CPAN::Meta::::BEGIN@1.3 CPAN::Meta::BEGIN@1.3
1 | 1 | 1 | 4µs | 5µs | CPAN::Meta::Converter::::BEGIN@27CPAN::Meta::Converter::BEGIN@27
4 | 1 | 1 | 4µs | 4µs | CPAN::Meta::Converter::::CORE:regcompCPAN::Meta::Converter::CORE:regcomp (opcode)
1 | 1 | 1 | 4µs | 10µs | CPAN::Meta::Converter::::BEGIN@506CPAN::Meta::Converter::BEGIN@506
1 | 1 | 1 | 3µs | 4µs | CPAN::Meta::::BEGIN@2.4 CPAN::Meta::BEGIN@2.4
1 | 1 | 1 | 3µs | 11µs | CPAN::Meta::::BEGIN@3.5 CPAN::Meta::BEGIN@3.5
4 | 1 | 1 | 2µs | 2µs | CPAN::Meta::Converter::::CORE:qrCPAN::Meta::Converter::CORE:qr (opcode)
2 | 2 | 1 | 900ns | 900ns | CPAN::Meta::Converter::::__ANON__CPAN::Meta::Converter::__ANON__ (xsub)
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:44]CPAN::Meta::Converter::__ANON__[:44]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:507]CPAN::Meta::Converter::__ANON__[:507]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:641]CPAN::Meta::Converter::__ANON__[:641]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:649]CPAN::Meta::Converter::__ANON__[:649]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:650]CPAN::Meta::Converter::__ANON__[:650]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:687]CPAN::Meta::Converter::__ANON__[:687]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:688]CPAN::Meta::Converter::__ANON__[:688]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:726]CPAN::Meta::Converter::__ANON__[:726]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:728]CPAN::Meta::Converter::__ANON__[:728]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::__ANON__[:729]CPAN::Meta::Converter::__ANON__[:729]
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_author_listCPAN::Meta::Converter::_author_list
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_bad_version_hookCPAN::Meta::Converter::_bad_version_hook
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_change_meta_specCPAN::Meta::Converter::_change_meta_spec
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_clean_versionCPAN::Meta::Converter::_clean_version
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_cleanup_optional_features_2CPAN::Meta::Converter::_cleanup_optional_features_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_cleanup_prereqsCPAN::Meta::Converter::_cleanup_prereqs
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_cleanup_resources_2CPAN::Meta::Converter::_cleanup_resources_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_convertCPAN::Meta::Converter::_convert
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_dcloneCPAN::Meta::Converter::_dclone
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_downgrade_licenseCPAN::Meta::Converter::_downgrade_license
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_downgrade_optional_featuresCPAN::Meta::Converter::_downgrade_optional_features
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_downgrade_resourcesCPAN::Meta::Converter::_downgrade_resources
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_extract_prereqsCPAN::Meta::Converter::_extract_prereqs
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_extract_spec_versionCPAN::Meta::Converter::_extract_spec_version
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_feature_2CPAN::Meta::Converter::_feature_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_generated_byCPAN::Meta::Converter::_generated_by
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_get_build_requiresCPAN::Meta::Converter::_get_build_requires
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_is_module_nameCPAN::Meta::Converter::_is_module_name
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_is_urlishCPAN::Meta::Converter::_is_urlish
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_keepCPAN::Meta::Converter::_keep
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_keep_or_oneCPAN::Meta::Converter::_keep_or_one
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_keep_or_unknownCPAN::Meta::Converter::_keep_or_unknown
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_keep_or_zeroCPAN::Meta::Converter::_keep_or_zero
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_license_1CPAN::Meta::Converter::_license_1
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_license_2CPAN::Meta::Converter::_license_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_listifyCPAN::Meta::Converter::_listify
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_no_index_1_2CPAN::Meta::Converter::_no_index_1_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_no_index_directoryCPAN::Meta::Converter::_no_index_directory
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_no_prefix_ucfirst_customCPAN::Meta::Converter::_no_prefix_ucfirst_custom
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_optional_features_1_4CPAN::Meta::Converter::_optional_features_1_4
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_optional_features_as_mapCPAN::Meta::Converter::_optional_features_as_map
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_prefix_customCPAN::Meta::Converter::_prefix_custom
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_prereqs_from_1CPAN::Meta::Converter::_prereqs_from_1
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_prereqs_relCPAN::Meta::Converter::_prereqs_rel
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_providesCPAN::Meta::Converter::_provides
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_release_statusCPAN::Meta::Converter::_release_status
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_release_status_from_versionCPAN::Meta::Converter::_release_status_from_version
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_repo_typeCPAN::Meta::Converter::_repo_type
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_resources_1_2CPAN::Meta::Converter::_resources_1_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_resources_1_3CPAN::Meta::Converter::_resources_1_3
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_ucfirst_customCPAN::Meta::Converter::_ucfirst_custom
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_upgrade_optional_featuresCPAN::Meta::Converter::_upgrade_optional_features
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_upgrade_resources_2CPAN::Meta::Converter::_upgrade_resources_2
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_url_listCPAN::Meta::Converter::_url_list
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_url_or_dropCPAN::Meta::Converter::_url_or_drop
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::_version_mapCPAN::Meta::Converter::_version_map
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::convertCPAN::Meta::Converter::convert
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::newCPAN::Meta::Converter::new
0 | 0 | 0 | 0s | 0s | CPAN::Meta::Converter::::upgrade_fragmentCPAN::Meta::Converter::upgrade_fragment

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 | 2 | 20µs | 1 | 7µs | # spent 7µs within CPAN::Meta::BEGIN@1.3 which was called: # once (7µs+0s) by CPAN::Meta::BEGIN@59 at line 1 use 5.006; # spent 7µs making 1 call to CPAN::Meta::BEGIN@1.3
2 | 2 | 10µs | 2 | 6µs | # spent 4µs (3+1) within CPAN::Meta::BEGIN@2.4 which was called: # once (3µs+1µs) by CPAN::Meta::BEGIN@59 at line 2 use strict; # spent 4µs making 1 call to CPAN::Meta::BEGIN@2.4 # spent 1µs making 1 call to strict::import
3 | 2 | 28µs | 2 | 19µs | # spent 11µs (3+8) within CPAN::Meta::BEGIN@3.5 which was called: # once (3µs+8µs) by CPAN::Meta::BEGIN@59 at line 3 use warnings; # spent 11µs making 1 call to CPAN::Meta::BEGIN@3.5 # spent 8µs making 1 call to warnings::import
4 |  |  |  |  | package CPAN::Meta::Converter;
5 |  |  |  |  |
6 | 1 | 300ns |  |  | 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 | 2 | 67µs | 2 | 2.40ms | # spent 2.40ms (2.38+20µs) within CPAN::Meta::Converter::BEGIN@26 which was called: # once (2.38ms+20µs) by CPAN::Meta::BEGIN@59 at line 26 use CPAN::Meta::Validator; # spent 2.40ms making 1 call to CPAN::Meta::Converter::BEGIN@26 # spent 700ns making 1 call to CPAN::Meta::Converter::__ANON__
27 | 2 | 15µs | 2 | 5µs | # spent 5µs (4+200ns) within CPAN::Meta::Converter::BEGIN@27 which was called: # once (4µs+200ns) by CPAN::Meta::BEGIN@59 at line 27 use CPAN::Meta::Requirements; # spent 5µs making 1 call to CPAN::Meta::Converter::BEGIN@27 # spent 200ns making 1 call to CPAN::Meta::Converter::__ANON__
28 | 3 | 62µs | 2 | 628µs | # spent 623µs (564+59) within CPAN::Meta::Converter::BEGIN@28 which was called: # once (564µs+59µs) by CPAN::Meta::BEGIN@59 at line 28 use Parse::CPAN::Meta 1.4400 (); # spent 623µs making 1 call to CPAN::Meta::Converter::BEGIN@28 # spent 5µs making 1 call to UNIVERSAL::VERSION
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 |  |  |  |  | # spent 19µs (16+2) within CPAN::Meta::Converter::BEGIN@36 which was called: # once (16µs+2µs) by CPAN::Meta::BEGIN@59 at line 41 BEGIN {
37 | 1 | 12µs |  |  | eval "use version ()"; ## no critic # spent 5µs executing statements in string eval # includes 2µs spent executing 1 call to 1 sub defined therein.
38 | 1 | 2µs |  |  | if ( my $err = $@ ) {
39 |  |  |  |  | eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic
40 |  |  |  |  | }
41 | 1 | 1.14ms | 1 | 19µs | } # spent 19µs making 1 call to CPAN::Meta::Converter::BEGIN@36
42 |  |  |  |  |
43 |  |  |  |  | # Perl 5.10.0 didn't have "is_qv" in version.pm
44 | 1 | 6µs | 1 | 1µs | *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; # spent 1µs making 1 call to UNIVERSAL::can
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 | 1 | 100ns |  |  | our $DCLONE_MAXDEPTH = 1024;
51 |  |  |  |  | our $_CLONE_DEPTH;
52 |  |  |  |  |
53 |  |  |  |  | sub _dclone {
54 |  |  |  |  | my ( $ref ) = @_;
55 |  |  |  |  | return $ref unless my $reftype = ref $ref;
56 |  |  |  |  |
57 |  |  |  |  | local $_CLONE_DEPTH = defined $_CLONE_DEPTH ? $_CLONE_DEPTH - 1 : $DCLONE_MAXDEPTH;
58 |  |  |  |  | die "Depth Limit $DCLONE_MAXDEPTH Exceeded" if $_CLONE_DEPTH == 0;
59 |  |  |  |  |
60 |  |  |  |  | return [ map { _dclone( $_ ) } @{$ref} ] if 'ARRAY' eq $reftype;
61 |  |  |  |  | return { map { $_ => _dclone( $ref->{$_} ) } keys %{$ref} } if 'HASH' eq $reftype;
62 |  |  |  |  |
63 |  |  |  |  | if ( 'SCALAR' eq $reftype ) {
64 |  |  |  |  | my $new = _dclone(${$ref});
65 |  |  |  |  | return \$new;
66 |  |  |  |  | }
67 |  |  |  |  |
68 |  |  |  |  | # We can't know if TO_JSON gives us cloned data, so refs must recurse
69 |  |  |  |  | if ( eval { $ref->can('TO_JSON') } ) {
70 |  |  |  |  | my $data = $ref->TO_JSON;
71 |  |  |  |  | return ref $data ? _dclone( $data ) : $data;
72 |  |  |  |  | }
73 |  |  |  |  |
74 |  |  |  |  | # Just stringify everything else
75 |  |  |  |  | return "$ref";
76 |  |  |  |  | }
77 |  |  |  |  |
78 | 1 | 2µs |  |  | 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 | 1 | 12µs | 1 | 9µs | my @spec_list = sort { $a <=> $b } keys %known_specs; # spent 9µs making 1 call to CPAN::Meta::Converter::CORE:sort
88 | 1 | 600ns |  |  | 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 |  |  |  |  | sub _keep { $_[0] }
100 |  |  |  |  |
101 |  |  |  |  | sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
102 |  |  |  |  |
103 |  |  |  |  | sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
104 |  |  |  |  |
105 |  |  |  |  | sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
106 |  |  |  |  |
107 |  |  |  |  | sub _generated_by {
108 |  |  |  |  | my $gen = shift;
109 |  |  |  |  | my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
110 |  |  |  |  |
111 |  |  |  |  | return $sig unless defined $gen and length $gen;
112 |  |  |  |  | return $gen if $gen =~ /\Q$sig/;
113 |  |  |  |  | return "$gen, $sig";
114 |  |  |  |  | }
115 |  |  |  |  |
116 |  |  |  |  | sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
117 |  |  |  |  |
118 |  |  |  |  | sub _prefix_custom {
119 |  |  |  |  | my $key = shift;
120 |  |  |  |  | $key =~ s/^(?!x_) # Unless it already starts with x_
121 |  |  |  |  | (?:x-?)? # Remove leading x- or x (if present)
122 |  |  |  |  | /x_/ix; # and prepend x_
123 |  |  |  |  | return $key;
124 |  |  |  |  | }
125 |  |  |  |  |
126 |  |  |  |  | sub _ucfirst_custom {
127 |  |  |  |  | my $key = shift;
128 |  |  |  |  | $key = ucfirst $key unless $key =~ /[A-Z]/;
129 |  |  |  |  | return $key;
130 |  |  |  |  | }
131 |  |  |  |  |
132 |  |  |  |  | sub _no_prefix_ucfirst_custom {
133 |  |  |  |  | my $key = shift;
134 |  |  |  |  | $key =~ s/^x_//;
135 |  |  |  |  | return _ucfirst_custom($key);
136 |  |  |  |  | }
137 |  |  |  |  |
138 |  |  |  |  | sub _change_meta_spec {
139 |  |  |  |  | my ($element, undef, undef, $version) = @_;
140 |  |  |  |  | return {
141 |  |  |  |  | version => $version,
142 |  |  |  |  | url => $known_specs{$version},
143 |  |  |  |  | };
144 |  |  |  |  | }
145 |  |  |  |  |
146 | 1 | 700ns |  |  | 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 | 1 | 4µs |  |  | my %is_open_source = map {; $_ => 1 } @open_source;
161 |  |  |  |  |
162 | 1 | 600ns |  |  | my @valid_licenses_1 = (
163 |  |  |  |  | @open_source,
164 |  |  |  |  | 'unrestricted',
165 |  |  |  |  | 'restrictive',
166 |  |  |  |  | 'unknown',
167 |  |  |  |  | );
168 |  |  |  |  |
169 |  |  |  |  | my %license_map_1 = (
170 | 1 | 3µs |  |  | ( map { $_ => $_ } @valid_licenses_1 ),
171 |  |  |  |  | artistic2 => 'artistic_2',
172 |  |  |  |  | );
173 |  |  |  |  |
174 |  |  |  |  | sub _license_1 {
175 |  |  |  |  | my ($element) = @_;
176 |  |  |  |  | return 'unknown' unless defined $element;
177 |  |  |  |  | if ( $license_map_1{lc $element} ) {
178 |  |  |  |  | return $license_map_1{lc $element};
179 |  |  |  |  | }
180 |  |  |  |  | else {
181 |  |  |  |  | return 'unknown';
182 |  |  |  |  | }
183 |  |  |  |  | }
184 |  |  |  |  |
185 | 1 | 1µs |  |  | 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 | 1 | 6µs |  |  | (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 |  |  |  |  | my ($element) = @_;
232 |  |  |  |  | return [ 'unknown' ] unless defined $element;
233 |  |  |  |  | $element = [ $element ] unless ref $element eq 'ARRAY';
234 |  |  |  |  | my @new_list;
235 |  |  |  |  | for my $lic ( @$element ) {
236 |  |  |  |  | next unless defined $lic;
237 |  |  |  |  | if ( my $new = $license_map_2{lc $lic} ) {
238 |  |  |  |  | push @new_list, $new;
239 |  |  |  |  | }
240 |  |  |  |  | }
241 |  |  |  |  | return @new_list ? \@new_list : [ 'unknown' ];
242 |  |  |  |  | }
243 |  |  |  |  |
244 | 1 | 3µs |  |  | 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 |  |  |  |  | my ($element) = @_;
276 |  |  |  |  | if ( ! defined $element ) {
277 |  |  |  |  | return "unknown";
278 |  |  |  |  | }
279 |  |  |  |  | elsif( ref $element eq 'ARRAY' ) {
280 |  |  |  |  | if ( @$element > 1) {
281 |  |  |  |  | if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) {
282 |  |  |  |  | return 'unknown';
283 |  |  |  |  | }
284 |  |  |  |  | else {
285 |  |  |  |  | return 'open_source';
286 |  |  |  |  | }
287 |  |  |  |  | }
288 |  |  |  |  | elsif ( @$element == 1 ) {
289 |  |  |  |  | return $license_downgrade_map{lc $element->[0]} || "unknown";
290 |  |  |  |  | }
291 |  |  |  |  | }
292 |  |  |  |  | elsif ( ! ref $element ) {
293 |  |  |  |  | return $license_downgrade_map{lc $element} || "unknown";
294 |  |  |  |  | }
295 |  |  |  |  | return "unknown";
296 |  |  |  |  | }
297 |  |  |  |  |
298 | 1 | 1µs |  |  | my $no_index_spec_1_2 = {
299 |  |  |  |  | 'file' => \&_listify,
300 |  |  |  |  | 'dir' => \&_listify,
301 |  |  |  |  | 'package' => \&_listify,
302 |  |  |  |  | 'namespace' => \&_listify,
303 |  |  |  |  | };
304 |  |  |  |  |
305 | 1 | 600ns |  |  | my $no_index_spec_1_3 = {
306 |  |  |  |  | 'file' => \&_listify,
307 |  |  |  |  | 'directory' => \&_listify,
308 |  |  |  |  | 'package' => \&_listify,
309 |  |  |  |  | 'namespace' => \&_listify,
310 |  |  |  |  | };
311 |  |  |  |  |
312 | 1 | 600ns |  |  | 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 |  |  |  |  | my (undef, undef, $meta) = @_;
322 |  |  |  |  | my $no_index = $meta->{no_index} || $meta->{private};
323 |  |  |  |  | return unless $no_index;
324 |  |  |  |  |
325 |  |  |  |  | # cleanup wrong format
326 |  |  |  |  | if ( ! ref $no_index ) {
327 |  |  |  |  | my $item = $no_index;
328 |  |  |  |  | $no_index = { dir => [ $item ], file => [ $item ] };
329 |  |  |  |  | }
330 |  |  |  |  | elsif ( ref $no_index eq 'ARRAY' ) {
331 |  |  |  |  | my $list = $no_index;
332 |  |  |  |  | $no_index = { dir => [ @$list ], file => [ @$list ] };
333 |  |  |  |  | }
334 |  |  |  |  |
335 |  |  |  |  | # common mistake: files -> file
336 |  |  |  |  | if ( exists $no_index->{files} ) {
337 |  |  |  |  | $no_index->{file} = delete $no_index->{files};
338 |  |  |  |  | }
339 |  |  |  |  | # common mistake: modules -> module
340 |  |  |  |  | if ( exists $no_index->{modules} ) {
341 |  |  |  |  | $no_index->{module} = delete $no_index->{modules};
342 |  |  |  |  | }
343 |  |  |  |  | return _convert($no_index, $no_index_spec_1_2);
344 |  |  |  |  | }
345 |  |  |  |  |
346 |  |  |  |  | sub _no_index_directory {
347 |  |  |  |  | my ($element, $key, $meta, $version) = @_;
348 |  |  |  |  | return unless $element;
349 |  |  |  |  |
350 |  |  |  |  | # clean up wrong format
351 |  |  |  |  | if ( ! ref $element ) {
352 |  |  |  |  | my $item = $element;
353 |  |  |  |  | $element = { directory => [ $item ], file => [ $item ] };
354 |  |  |  |  | }
355 |  |  |  |  | elsif ( ref $element eq 'ARRAY' ) {
356 |  |  |  |  | my $list = $element;
357 |  |  |  |  | $element = { directory => [ @$list ], file => [ @$list ] };
358 |  |  |  |  | }
359 |  |  |  |  |
360 |  |  |  |  | if ( exists $element->{dir} ) {
361 |  |  |  |  | $element->{directory} = delete $element->{dir};
362 |  |  |  |  | }
363 |  |  |  |  | # common mistake: files -> file
364 |  |  |  |  | if ( exists $element->{files} ) {
365 |  |  |  |  | $element->{file} = delete $element->{files};
366 |  |  |  |  | }
367 |  |  |  |  | # common mistake: modules -> module
368 |  |  |  |  | if ( exists $element->{modules} ) {
369 |  |  |  |  | $element->{module} = delete $element->{modules};
370 |  |  |  |  | }
371 |  |  |  |  | my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
372 |  |  |  |  | return _convert($element, $spec);
373 |  |  |  |  | }
374 |  |  |  |  |
375 |  |  |  |  | sub _is_module_name {
376 |  |  |  |  | my $mod = shift;
377 |  |  |  |  | return unless defined $mod && length $mod;
378 |  |  |  |  | return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
379 |  |  |  |  | }
380 |  |  |  |  |
381 |  |  |  |  | sub _clean_version {
382 |  |  |  |  | my ($element) = @_;
383 |  |  |  |  | return 0 if ! defined $element;
384 |  |  |  |  |
385 |  |  |  |  | $element =~ s{^\s*}{};
386 |  |  |  |  | $element =~ s{\s*$}{};
387 |  |  |  |  | $element =~ s{^\.}{0.};
388 |  |  |  |  |
389 |  |  |  |  | return 0 if ! length $element;
390 |  |  |  |  | return 0 if ( $element eq 'undef' || $element eq '<undef>' );
391 |  |  |  |  |
392 |  |  |  |  | my $v = eval { version->new($element) };
393 |  |  |  |  | # XXX check defined $v and not just $v because version objects leak memory
394 |  |  |  |  | # in boolean context -- dagolden, 2012-02-03
395 |  |  |  |  | if ( defined $v ) {
396 |  |  |  |  | return _is_qv($v) ? $v->normal : $element;
397 |  |  |  |  | }
398 |  |  |  |  | else {
399 |  |  |  |  | return 0;
400 |  |  |  |  | }
401 |  |  |  |  | }
402 |  |  |  |  |
403 |  |  |  |  | sub _bad_version_hook {
404 |  |  |  |  | my ($v) = @_;
405 |  |  |  |  | $v =~ s{^\s*}{};
406 |  |  |  |  | $v =~ s{\s*$}{};
407 |  |  |  |  | $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
408 |  |  |  |  | my $vobj = eval { version->new($v) };
409 |  |  |  |  | return defined($vobj) ? $vobj : version->new(0); # or give up
410 |  |  |  |  | }
411 |  |  |  |  |
412 |  |  |  |  | sub _version_map {
413 |  |  |  |  | my ($element) = @_;
414 |  |  |  |  | return unless defined $element;
415 |  |  |  |  | if ( ref $element eq 'HASH' ) {
416 |  |  |  |  | # XXX turn this into CPAN::Meta::Requirements with bad version hook
417 |  |  |  |  | # and then turn it back into a hash
418 |  |  |  |  | my $new_map = CPAN::Meta::Requirements->new(
419 |  |  |  |  | { bad_version_hook => \&_bad_version_hook } # punt
420 |  |  |  |  | );
421 |  |  |  |  | while ( my ($k,$v) = each %$element ) {
422 |  |  |  |  | next unless _is_module_name($k);
423 |  |  |  |  | if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
424 |  |  |  |  | $v = 0;
425 |  |  |  |  | }
426 |  |  |  |  | # some weird, old META have bad yml with module => module
427 |  |  |  |  | # so check if value is like a module name and not like a version
428 |  |  |  |  | if ( _is_module_name($v) && ! version::is_lax($v) ) {
429 |  |  |  |  | $new_map->add_minimum($k => 0);
430 |  |  |  |  | $new_map->add_minimum($v => 0);
431 |  |  |  |  | }
432 |  |  |  |  | $new_map->add_string_requirement($k => $v);
433 |  |  |  |  | }
434 |  |  |  |  | return $new_map->as_string_hash;
435 |  |  |  |  | }
436 |  |  |  |  | elsif ( ref $element eq 'ARRAY' ) {
437 |  |  |  |  | my $hashref = { map { $_ => 0 } @$element };
438 |  |  |  |  | return _version_map($hashref); # clean up any weird stuff
439 |  |  |  |  | }
440 |  |  |  |  | elsif ( ref $element eq '' && length $element ) {
441 |  |  |  |  | return { $element => 0 }
442 |  |  |  |  | }
443 |  |  |  |  | return;
444 |  |  |  |  | }
445 |  |  |  |  |
446 |  |  |  |  | sub _prereqs_from_1 {
447 |  |  |  |  | my (undef, undef, $meta) = @_;
448 |  |  |  |  | my $prereqs = {};
449 |  |  |  |  | for my $phase ( qw/build configure/ ) {
450 |  |  |  |  | my $key = "${phase}_requires";
451 |  |  |  |  | $prereqs->{$phase}{requires} = _version_map($meta->{$key})
452 |  |  |  |  | if $meta->{$key};
453 |  |  |  |  | }
454 |  |  |  |  | for my $rel ( qw/requires recommends conflicts/ ) {
455 |  |  |  |  | $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
456 |  |  |  |  | if $meta->{$rel};
457 |  |  |  |  | }
458 |  |  |  |  | return $prereqs;
459 |  |  |  |  | }
460 |  |  |  |  |
461 | 1 | 800ns |  |  | 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 | 1 | 800ns |  |  | 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 |  |  |  |  | my ($prereqs, $key, $meta, $to_version) = @_;
480 |  |  |  |  | return unless $prereqs && ref $prereqs eq 'HASH';
481 |  |  |  |  | return _convert( $prereqs, $prereqs_spec, $to_version );
482 |  |  |  |  | }
483 |  |  |  |  |
484 |  |  |  |  | sub _prereqs_rel {
485 |  |  |  |  | my ($relation, $key, $meta, $to_version) = @_;
486 |  |  |  |  | return unless $relation && ref $relation eq 'HASH';
487 |  |  |  |  | return _convert( $relation, $relation_spec, $to_version );
488 |  |  |  |  | }
489 |  |  |  |  |
490 |  |  |  |  |
491 |  |  |  |  | # spent 31µs (25+6) within CPAN::Meta::Converter::BEGIN@491 which was called: # once (25µs+6µs) by CPAN::Meta::BEGIN@59 at line 509 BEGIN {
492 | 1 | 700ns |  |  | my @old_prereqs = qw(
493 |  |  |  |  | requires
494 |  |  |  |  | configure_requires
495 |  |  |  |  | recommends
496 |  |  |  |  | conflicts
497 |  |  |  |  | );
498 |  |  |  |  |
499 | 1 | 2µs |  |  | for ( @old_prereqs ) {
500 | 4 | 800ns |  |  | my $sub = "_get_$_";
501 | 4 | 18µs | 8 | 6µs | my ($phase,$type) = split qr/_/, $_; # spent 4µs making 4 calls to CPAN::Meta::Converter::CORE:regcomp, avg 1µs/call # spent 2µs making 4 calls to CPAN::Meta::Converter::CORE:qr, avg 400ns/call
502 | 4 | 600ns |  |  | if ( ! defined $type ) {
503 | 3 | 400ns |  |  | $type = $phase;
504 | 3 | 400ns |  |  | $phase = 'runtime';
505 |  |  |  |  | }
506 | 2 | 39µs | 2 | 16µs | # spent 10µs (4+6) within CPAN::Meta::Converter::BEGIN@506 which was called: # once (4µs+6µs) by CPAN::Meta::BEGIN@59 at line 506 no strict 'refs'; # spent 10µs making 1 call to CPAN::Meta::Converter::BEGIN@506 # spent 6µs making 1 call to strict::unimport
507 | 4 | 8µs |  |  | *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
508 |  |  |  |  | }
509 | 1 | 2.42ms | 1 | 31µs | } # spent 31µs making 1 call to CPAN::Meta::Converter::BEGIN@491
510 |  |  |  |  |
511 |  |  |  |  | sub _get_build_requires {
512 |  |  |  |  | my ($data, $key, $meta) = @_;
513 |  |  |  |  |
514 |  |  |  |  | my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
515 |  |  |  |  | my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
516 |  |  |  |  |
517 |  |  |  |  | my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
518 |  |  |  |  | my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
519 |  |  |  |  |
520 |  |  |  |  | $test_req->add_requirements($build_req)->as_string_hash;
521 |  |  |  |  | }
522 |  |  |  |  |
523 |  |  |  |  | sub _extract_prereqs {
524 |  |  |  |  | my ($prereqs, $phase, $type) = @_;
525 |  |  |  |  | return unless ref $prereqs eq 'HASH';
526 |  |  |  |  | return scalar _version_map($prereqs->{$phase}{$type});
527 |  |  |  |  | }
528 |  |  |  |  |
529 |  |  |  |  | sub _downgrade_optional_features {
530 |  |  |  |  | my (undef, undef, $meta) = @_;
531 |  |  |  |  | return unless exists $meta->{optional_features};
532 |  |  |  |  | my $origin = $meta->{optional_features};
533 |  |  |  |  | my $features = {};
534 |  |  |  |  | for my $name ( keys %$origin ) {
535 |  |  |  |  | $features->{$name} = {
536 |  |  |  |  | description => $origin->{$name}{description},
537 |  |  |  |  | requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
538 |  |  |  |  | configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
539 |  |  |  |  | build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
540 |  |  |  |  | recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
541 |  |  |  |  | conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
542 |  |  |  |  | };
543 |  |  |  |  | for my $k (keys %{$features->{$name}} ) {
544 |  |  |  |  | delete $features->{$name}{$k} unless defined $features->{$name}{$k};
545 |  |  |  |  | }
546 |  |  |  |  | }
547 |  |  |  |  | return $features;
548 |  |  |  |  | }
549 |  |  |  |  |
550 |  |  |  |  | sub _upgrade_optional_features {
551 |  |  |  |  | my (undef, undef, $meta) = @_;
552 |  |  |  |  | return unless exists $meta->{optional_features};
553 |  |  |  |  | my $origin = $meta->{optional_features};
554 |  |  |  |  | my $features = {};
555 |  |  |  |  | for my $name ( keys %$origin ) {
556 |  |  |  |  | $features->{$name} = {
557 |  |  |  |  | description => $origin->{$name}{description},
558 |  |  |  |  | prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
559 |  |  |  |  | };
560 |  |  |  |  | delete $features->{$name}{prereqs}{configure};
561 |  |  |  |  | }
562 |  |  |  |  | return $features;
563 |  |  |  |  | }
564 |  |  |  |  |
565 | 1 | 600ns |  |  | my $optional_features_2_spec = {
566 |  |  |  |  | description => \&_keep,
567 |  |  |  |  | prereqs => \&_cleanup_prereqs,
568 |  |  |  |  | ':custom' => \&_prefix_custom,
569 |  |  |  |  | };
570 |  |  |  |  |
571 |  |  |  |  | sub _feature_2 {
572 |  |  |  |  | my ($element, $key, $meta, $to_version) = @_;
573 |  |  |  |  | return unless $element && ref $element eq 'HASH';
574 |  |  |  |  | _convert( $element, $optional_features_2_spec, $to_version );
575 |  |  |  |  | }
576 |  |  |  |  |
577 |  |  |  |  | sub _cleanup_optional_features_2 {
578 |  |  |  |  | my ($element, $key, $meta, $to_version) = @_;
579 |  |  |  |  | return unless $element && ref $element eq 'HASH';
580 |  |  |  |  | my $new_data = {};
581 |  |  |  |  | for my $k ( keys %$element ) {
582 |  |  |  |  | $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
583 |  |  |  |  | }
584 |  |  |  |  | return unless keys %$new_data;
585 |  |  |  |  | return $new_data;
586 |  |  |  |  | }
587 |  |  |  |  |
588 |  |  |  |  | sub _optional_features_1_4 {
589 |  |  |  |  | my ($element) = @_;
590 |  |  |  |  | return unless $element;
591 |  |  |  |  | $element = _optional_features_as_map($element);
592 |  |  |  |  | for my $name ( keys %$element ) {
593 |  |  |  |  | for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
594 |  |  |  |  | delete $element->{$name}{$drop};
595 |  |  |  |  | }
596 |  |  |  |  | }
597 |  |  |  |  | return $element;
598 |  |  |  |  | }
599 |  |  |  |  |
600 |  |  |  |  | sub _optional_features_as_map {
601 |  |  |  |  | my ($element) = @_;
602 |  |  |  |  | return unless $element;
603 |  |  |  |  | if ( ref $element eq 'ARRAY' ) {
604 |  |  |  |  | my %map;
605 |  |  |  |  | for my $feature ( @$element ) {
606 |  |  |  |  | my (@parts) = %$feature;
607 |  |  |  |  | $map{$parts[0]} = $parts[1];
608 |  |  |  |  | }
609 |  |  |  |  | $element = \%map;
610 |  |  |  |  | }
611 |  |  |  |  | return $element;
612 |  |  |  |  | }
613 |  |  |  |  |
614 |  |  |  |  | sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
615 |  |  |  |  |
616 |  |  |  |  | sub _url_or_drop {
617 |  |  |  |  | my ($element) = @_;
618 |  |  |  |  | return $element if _is_urlish($element);
619 |  |  |  |  | return;
620 |  |  |  |  | }
621 |  |  |  |  |
622 |  |  |  |  | sub _url_list {
623 |  |  |  |  | my ($element) = @_;
624 |  |  |  |  | return unless $element;
625 |  |  |  |  | $element = _listify( $element );
626 |  |  |  |  | $element = [ grep { _is_urlish($_) } @$element ];
627 |  |  |  |  | return unless @$element;
628 |  |  |  |  | return $element;
629 |  |  |  |  | }
630 |  |  |  |  |
631 |  |  |  |  | sub _author_list {
632 |  |  |  |  | my ($element) = @_;
633 |  |  |  |  | return [ 'unknown' ] unless $element;
634 |  |  |  |  | $element = _listify( $element );
635 |  |  |  |  | $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
636 |  |  |  |  | return [ 'unknown' ] unless @$element;
637 |  |  |  |  | return $element;
638 |  |  |  |  | }
639 |  |  |  |  |
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 | 1 | 2µs |  |  | ':custom' => \&_prefix_custom,
652 |  |  |  |  | };
653 |  |  |  |  |
654 |  |  |  |  | sub _upgrade_resources_2 {
655 |  |  |  |  | my (undef, undef, $meta, $version) = @_;
656 |  |  |  |  | return unless exists $meta->{resources};
657 |  |  |  |  | return _convert($meta->{resources}, $resource2_upgrade);
658 |  |  |  |  | }
659 |  |  |  |  |
660 | 1 | 500ns |  |  | my $bugtracker2_spec = {
661 |  |  |  |  | web => \&_url_or_drop,
662 |  |  |  |  | mailto => \&_keep,
663 |  |  |  |  | ':custom' => \&_prefix_custom,
664 |  |  |  |  | };
665 |  |  |  |  |
666 |  |  |  |  | sub _repo_type {
667 |  |  |  |  | my ($element, $key, $meta, $to_version) = @_;
668 |  |  |  |  | return $element if defined $element;
669 |  |  |  |  | return unless exists $meta->{url};
670 |  |  |  |  | my $repo_url = $meta->{url};
671 |  |  |  |  | for my $type ( qw/git svn/ ) {
672 |  |  |  |  | return $type if $repo_url =~ m{\A$type};
673 |  |  |  |  | }
674 |  |  |  |  | return;
675 |  |  |  |  | }
676 |  |  |  |  |
677 | 1 | 600ns |  |  | 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 | 1 | 2µs |  |  | ':custom' => \&_prefix_custom,
690 |  |  |  |  | };
691 |  |  |  |  |
692 |  |  |  |  | sub _cleanup_resources_2 {
693 |  |  |  |  | my ($resources, $key, $meta, $to_version) = @_;
694 |  |  |  |  | return unless $resources && ref $resources eq 'HASH';
695 |  |  |  |  | return _convert($resources, $resources2_cleanup, $to_version);
696 |  |  |  |  | }
697 |  |  |  |  |
698 | 1 | 600ns |  |  | 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 |  |  |  |  | my (undef, undef, $meta, $version) = @_;
708 |  |  |  |  | return unless exists $meta->{resources};
709 |  |  |  |  | return _convert($meta->{resources}, $resource1_spec);
710 |  |  |  |  | }
711 |  |  |  |  |
712 | 1 | 900ns |  |  | *_resources_1_4 = *_resources_1_3;
713 |  |  |  |  |
714 |  |  |  |  | sub _resources_1_2 {
715 |  |  |  |  | my (undef, undef, $meta) = @_;
716 |  |  |  |  | my $resources = $meta->{resources} || {};
717 |  |  |  |  | if ( $meta->{license_url} && ! $resources->{license} ) {
718 |  |  |  |  | $resources->{license} = $meta->{license_url}
719 |  |  |  |  | if _is_urlish($meta->{license_url});
720 |  |  |  |  | }
721 |  |  |  |  | return unless keys %$resources;
722 |  |  |  |  | return _convert($resources, $resource1_spec);
723 |  |  |  |  | }
724 |  |  |  |  |
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 | 1 | 2µs |  |  | ':custom' => \&_no_prefix_ucfirst_custom,
731 |  |  |  |  | };
732 |  |  |  |  |
733 |  |  |  |  | sub _downgrade_resources {
734 |  |  |  |  | my (undef, undef, $meta, $version) = @_;
735 |  |  |  |  | return unless exists $meta->{resources};
736 |  |  |  |  | return _convert($meta->{resources}, $resource_downgrade_spec);
737 |  |  |  |  | }
738 |  |  |  |  |
739 |  |  |  |  | sub _release_status {
740 |  |  |  |  | my ($element, undef, $meta) = @_;
741 |  |  |  |  | return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
742 |  |  |  |  | return _release_status_from_version(undef, undef, $meta);
743 |  |  |  |  | }
744 |  |  |  |  |
745 |  |  |  |  | sub _release_status_from_version {
746 |  |  |  |  | my (undef, undef, $meta) = @_;
747 |  |  |  |  | my $version = $meta->{version} || '';
748 |  |  |  |  | return ( $version =~ /_/ ) ? 'testing' : 'stable';
749 |  |  |  |  | }
750 |  |  |  |  |
751 | 1 | 400ns |  |  | my $provides_spec = {
752 |  |  |  |  | file => \&_keep,
753 |  |  |  |  | version => \&_keep,
754 |  |  |  |  | };
755 |  |  |  |  |
756 | 1 | 500ns |  |  | my $provides_spec_2 = {
757 |  |  |  |  | file => \&_keep,
758 |  |  |  |  | version => \&_keep,
759 |  |  |  |  | ':custom' => \&_prefix_custom,
760 |  |  |  |  | };
761 |  |  |  |  |
762 |  |  |  |  | sub _provides {
763 |  |  |  |  | my ($element, $key, $meta, $to_version) = @_;
764 |  |  |  |  | return unless defined $element && ref $element eq 'HASH';
765 |  |  |  |  | my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
766 |  |  |  |  | my $new_data = {};
767 |  |  |  |  | for my $k ( keys %$element ) {
768 |  |  |  |  | $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
769 |  |  |  |  | $new_data->{$k}{version} = _clean_version($element->{$k}{version})
770 |  |  |  |  | if exists $element->{$k}{version};
771 |  |  |  |  | }
772 |  |  |  |  | return $new_data;
773 |  |  |  |  | }
774 |  |  |  |  |
775 |  |  |  |  | sub _convert {
776 |  |  |  |  | my ($data, $spec, $to_version, $is_fragment) = @_;
777 |  |  |  |  |
778 |  |  |  |  | my $new_data = {};
779 |  |  |  |  | for my $key ( keys %$spec ) {
780 |  |  |  |  | next if $key eq ':custom' || $key eq ':drop';
781 |  |  |  |  | next unless my $fcn = $spec->{$key};
782 |  |  |  |  | if ( $is_fragment && $key eq 'generated_by' ) {
783 |  |  |  |  | $fcn = \&_keep;
784 |  |  |  |  | }
785 |  |  |  |  | die "spec for '$key' is not a coderef"
786 |  |  |  |  | unless ref $fcn && ref $fcn eq 'CODE';
787 |  |  |  |  | my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
788 |  |  |  |  | $new_data->{$key} = $new_value if defined $new_value;
789 |  |  |  |  | }
790 |  |  |  |  |
791 |  |  |  |  | my $drop_list = $spec->{':drop'};
792 |  |  |  |  | my $customizer = $spec->{':custom'} || \&_keep;
793 |  |  |  |  |
794 |  |  |  |  | for my $key ( keys %$data ) {
795 |  |  |  |  | next if $drop_list && grep { $key eq $_ } @$drop_list;
796 |  |  |  |  | next if exists $spec->{$key}; # we handled it
797 |  |  |  |  | $new_data->{ $customizer->($key) } = $data->{$key};
798 |  |  |  |  | }
799 |  |  |  |  |
800 |  |  |  |  | return $new_data;
801 |  |  |  |  | }
802 |  |  |  |  |
803 |  |  |  |  | #--------------------------------------------------------------------------#
804 |  |  |  |  | # define converters for each conversion
805 |  |  |  |  | #--------------------------------------------------------------------------#
806 |  |  |  |  |
807 |  |  |  |  | # each converts from prior version
808 |  |  |  |  | # special ":custom" field is used for keys not recognized in spec
809 | 1 | 14µs |  |  | 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 | 1 | 11µs |  |  | 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 | 1 | 13µs |  |  | 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 | 1 | 4µs |  |  | 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 | 1 | 2µs |  |  | $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/;
1314 |  |  |  |  |
1315 |  |  |  |  | #--------------------------------------------------------------------------#
1316 |  |  |  |  | # Code
1317 |  |  |  |  | #--------------------------------------------------------------------------#
1318 |  |  |  |  |
1319 |  |  |  |  | #pod =method new
1320 |  |  |  |  | #pod
1321 |  |  |  |  | #pod my $cmc = CPAN::Meta::Converter->new( $struct );
1322 |  |  |  |  | #pod
1323 |  |  |  |  | #pod The constructor should be passed a valid metadata structure but invalid
1324 |  |  |  |  | #pod structures are accepted. If no meta-spec version is provided, version 1.0 will
1325 |  |  |  |  | #pod be assumed.
1326 |  |  |  |  | #pod
1327 |  |  |  |  | #pod Optionally, you can provide a C<default_version> argument after C<$struct>:
1328 |  |  |  |  | #pod
1329 |  |  |  |  | #pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" );
1330 |  |  |  |  | #pod
1331 |  |  |  |  | #pod This is only needed when converting a metadata fragment that does not include a
1332 |  |  |  |  | #pod C<meta-spec> field.
1333 |  |  |  |  | #pod
1334 |  |  |  |  | #pod =cut
1335 |  |  |  |  |
1336 |  |  |  |  | sub new {
1337 |  |  |  |  | my ($class,$data,%args) = @_;
1338 |  |  |  |  |
1339 |  |  |  |  | # create an attributes hash
1340 |  |  |  |  | my $self = {
1341 |  |  |  |  | 'data' => $data,
1342 |  |  |  |  | 'spec' => _extract_spec_version($data, $args{default_version}),
1343 |  |  |  |  | };
1344 |  |  |  |  |
1345 |  |  |  |  | # create the object
1346 |  |  |  |  | return bless $self, $class;
1347 |  |  |  |  | }
1348 |  |  |  |  |
1349 |  |  |  |  | sub _extract_spec_version {
1350 |  |  |  |  | my ($data, $default) = @_;
1351 |  |  |  |  | my $spec = $data->{'meta-spec'};
1352 |  |  |  |  |
1353 |  |  |  |  | # is meta-spec there and valid?
1354 |  |  |  |  | return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec?
1355 |  |  |  |  |
1356 |  |  |  |  | # does the version key look like a valid version?
1357 |  |  |  |  | my $v = $spec->{version};
1358 |  |  |  |  | if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) {
1359 |  |  |  |  | return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec
1360 |  |  |  |  | return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2
1361 |  |  |  |  | }
1362 |  |  |  |  |
1363 |  |  |  |  | # otherwise, use heuristics: look for 1.x vs 2.0 fields
1364 |  |  |  |  | return "2" if exists $data->{prereqs};
1365 |  |  |  |  | return "1.4" if exists $data->{configure_requires};
1366 |  |  |  |  | return( $default || "1.2" ); # when meta-spec was first defined
1367 |  |  |  |  | }
1368 |  |  |  |  |
1369 |  |  |  |  | #pod =method convert
1370 |  |  |  |  | #pod
1371 |  |  |  |  | #pod my $new_struct = $cmc->convert( version => "2" );
1372 |  |  |  |  | #pod
1373 |  |  |  |  | #pod Returns a new hash reference with the metadata converted to a different form.
1374 |  |  |  |  | #pod C<convert> will die if any conversion/standardization still results in an
1375 |  |  |  |  | #pod invalid structure.
1376 |  |  |  |  | #pod
1377 |  |  |  |  | #pod Valid parameters include:
1378 |  |  |  |  | #pod
1379 |  |  |  |  | #pod =over
1380 |  |  |  |  | #pod
1381 |  |  |  |  | #pod =item *
1382 |  |  |  |  | #pod
1383 |  |  |  |  | #pod C<version> -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2").
1384 |  |  |  |  | #pod Defaults to the latest version of the CPAN Meta Spec.
1385 |  |  |  |  | #pod
1386 |  |  |  |  | #pod =back
1387 |  |  |  |  | #pod
1388 |  |  |  |  | #pod Conversion proceeds through each version in turn. For example, a version 1.2
1389 |  |  |  |  | #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The
1390 |  |  |  |  | #pod conversion process attempts to clean-up simple errors and standardize data.
1391 |  |  |  |  | #pod For example, if C<author> is given as a scalar, it will converted to an array
1392 |  |  |  |  | #pod reference containing the item. (Converting a structure to its own version will
1393 |  |  |  |  | #pod also clean-up and standardize.)
1394 |  |  |  |  | #pod
1395 |  |  |  |  | #pod When data are cleaned and standardized, missing or invalid fields will be
1396 |  |  |  |  | #pod replaced with sensible defaults when possible. This may be lossy or imprecise.
1397 |  |  |  |  | #pod For example, some badly structured META.yml files on CPAN have prerequisite
1398 |  |  |  |  | #pod modules listed as both keys and values:
1399 |  |  |  |  | #pod
1400 |  |  |  |  | #pod requires => { 'Foo::Bar' => 'Bam::Baz' }
1401 |  |  |  |  | #pod
1402 |  |  |  |  | #pod These would be split and each converted to a prerequisite with a minimum
1403 |  |  |  |  | #pod version of zero.
1404 |  |  |  |  | #pod
1405 |  |  |  |  | #pod When some mandatory fields are missing or invalid, the conversion will attempt
1406 |  |  |  |  | #pod to provide a sensible default or will fill them with a value of 'unknown'. For
1407 |  |  |  |  | #pod example a missing or unrecognized C<license> field will result in a C<license>
1408 |  |  |  |  | #pod field of 'unknown'. Fields that may get an 'unknown' include:
1409 |  |  |  |  | #pod
1410 |  |  |  |  | #pod =for :list
1411 |  |  |  |  | #pod * abstract
1412 |  |  |  |  | #pod * author
1413 |  |  |  |  | #pod * license
1414 |  |  |  |  | #pod
1415 |  |  |  |  | #pod =cut
1416 |  |  |  |  |
1417 |  |  |  |  | sub convert {
1418 |  |  |  |  | my ($self, %args) = @_;
1419 |  |  |  |  | my $args = { %args };
1420 |  |  |  |  |
1421 |  |  |  |  | my $new_version = $args->{version} || $HIGHEST;
1422 |  |  |  |  | my $is_fragment = $args->{is_fragment};
1423 |  |  |  |  |
1424 |  |  |  |  | my ($old_version) = $self->{spec};
1425 |  |  |  |  | my $converted = _dclone($self->{data});
1426 |  |  |  |  |
1427 |  |  |  |  | if ( $old_version == $new_version ) {
1428 |  |  |  |  | $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment );
1429 |  |  |  |  | unless ( $args->{is_fragment} ) {
1430 |  |  |  |  | my $cmv = CPAN::Meta::Validator->new( $converted );
1431 |  |  |  |  | unless ( $cmv->is_valid ) {
1432 |  |  |  |  | my $errs = join("\n", $cmv->errors);
1433 |  |  |  |  | die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
1434 |  |  |  |  | }
1435 |  |  |  |  | }
1436 |  |  |  |  | return $converted;
1437 |  |  |  |  | }
1438 |  |  |  |  | elsif ( $old_version > $new_version ) {
1439 |  |  |  |  | my @vers = sort { $b <=> $a } keys %known_specs;
1440 |  |  |  |  | for my $i ( 0 .. $#vers-1 ) {
1441 |  |  |  |  | next if $vers[$i] > $old_version;
1442 |  |  |  |  | last if $vers[$i+1] < $new_version;
1443 |  |  |  |  | my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1444 |  |  |  |  | $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment );
1445 |  |  |  |  | unless ( $args->{is_fragment} ) {
1446 |  |  |  |  | my $cmv = CPAN::Meta::Validator->new( $converted );
1447 |  |  |  |  | unless ( $cmv->is_valid ) {
1448 |  |  |  |  | my $errs = join("\n", $cmv->errors);
1449 |  |  |  |  | die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1450 |  |  |  |  | }
1451 |  |  |  |  | }
1452 |  |  |  |  | }
1453 |  |  |  |  | return $converted;
1454 |  |  |  |  | }
1455 |  |  |  |  | else {
1456 |  |  |  |  | my @vers = sort { $a <=> $b } keys %known_specs;
1457 |  |  |  |  | for my $i ( 0 .. $#vers-1 ) {
1458 |  |  |  |  | next if $vers[$i] < $old_version;
1459 |  |  |  |  | last if $vers[$i+1] > $new_version;
1460 |  |  |  |  | my $spec_string = "$vers[$i+1]-from-$vers[$i]";
1461 |  |  |  |  | $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment );
1462 |  |  |  |  | unless ( $args->{is_fragment} ) {
1463 |  |  |  |  | my $cmv = CPAN::Meta::Validator->new( $converted );
1464 |  |  |  |  | unless ( $cmv->is_valid ) {
1465 |  |  |  |  | my $errs = join("\n", $cmv->errors);
1466 |  |  |  |  | die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
1467 |  |  |  |  | }
1468 |  |  |  |  | }
1469 |  |  |  |  | }
1470 |  |  |  |  | return $converted;
1471 |  |  |  |  | }
1472 |  |  |  |  | }
1473 |  |  |  |  |
1474 |  |  |  |  | #pod =method upgrade_fragment
1475 |  |  |  |  | #pod
1476 |  |  |  |  | #pod my $new_struct = $cmc->upgrade_fragment;
1477 |  |  |  |  | #pod
1478 |  |  |  |  | #pod Returns a new hash reference with the metadata converted to the latest version
1479 |  |  |  |  | #pod of the CPAN Meta Spec. No validation is done on the result -- you must
1480 |  |  |  |  | #pod validate after merging fragments into a complete metadata document.
1481 |  |  |  |  | #pod
1482 |  |  |  |  | #pod Available since version 2.141170.
1483 |  |  |  |  | #pod
1484 |  |  |  |  | #pod =cut
1485 |  |  |  |  |
1486 |  |  |  |  | sub upgrade_fragment {
1487 |  |  |  |  | my ($self) = @_;
1488 |  |  |  |  | my ($old_version) = $self->{spec};
1489 |  |  |  |  | my %expected =
1490 |  |  |  |  | map {; $_ => 1 }
1491 |  |  |  |  | grep { defined }
1492 |  |  |  |  | map { $fragments_generate{$old_version}{$_} }
1493 |  |  |  |  | keys %{ $self->{data} };
1494 |  |  |  |  | my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 );
1495 |  |  |  |  | for my $key ( keys %$converted ) {
1496 |  |  |  |  | next if $key =~ /^x_/i || $key eq 'meta-spec';
1497 |  |  |  |  | delete $converted->{$key} unless $expected{$key};
1498 |  |  |  |  | }
1499 |  |  |  |  | return $converted;
1500 |  |  |  |  | }
1501 |  |  |  |  |
1502 | 1 | 65µs |  |  | 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<default_version> 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<meta-spec> 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<convert> 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<version> -- 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<author> 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<license> field will result in a C<license>
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<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
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 <dagolden@cpan.org>
1634 |  |  |  |  |
1635 |  |  |  |  | =item *
1636 |  |  |  |  |
1637 |  |  |  |  | Ricardo Signes <rjbs@cpan.org>
1638 |  |  |  |  |
1639 |  |  |  |  | =item *
1640 |  |  |  |  |
1641 |  |  |  |  | Adam Kennedy <adamk@cpan.org>
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__
|  |  |  |  | # spent 2µs within CPAN::Meta::Converter::CORE:qr which was called 4 times, avg 400ns/call: # 4 times (2µs+0s) by CPAN::Meta::Converter::BEGIN@491 at line 501, avg 400ns/call sub CPAN::Meta::Converter::CORE:qr; # opcode
|  |  |  |  | # spent 4µs within CPAN::Meta::Converter::CORE:regcomp which was called 4 times, avg 1µs/call: # 4 times (4µs+0s) by CPAN::Meta::Converter::BEGIN@491 at line 501, avg 1µs/call sub CPAN::Meta::Converter::CORE:regcomp; # opcode
|  |  |  |  | # spent 9µs within CPAN::Meta::Converter::CORE:sort which was called: # once (9µs+0s) by CPAN::Meta::BEGIN@59 at line 87 sub CPAN::Meta::Converter::CORE:sort; # opcode
|  |  |  |  | # spent 900ns within CPAN::Meta::Converter::__ANON__ which was called 2 times, avg 450ns/call: # once (700ns+0s) by CPAN::Meta::Converter::BEGIN@26 at line 26 # once (200ns+0s) by CPAN::Meta::Converter::BEGIN@27 at line 27 sub CPAN::Meta::Converter::__ANON__; # xsub