File Coverage

lib/Gentoo/PerlMod/Version.pm
Criterion Covered Total %
statement 110 116 94.8
branch 34 40 85.0
condition 2 2 100.0
subroutine 18 18 100.0
pod 1 1 100.0
total 165 177 93.2


line stmt bran cond sub pod time code
1 4     4   58340 use 5.006;
  4         11  
  4         151  
2 4     4   18 use strict;
  4         5  
  4         117  
3 4     4   15 use warnings;
  4         5  
  4         278  
4              
5             package Gentoo::PerlMod::Version;
6              
7             our $VERSION = '0.7.1';
8              
9             # ABSTRACT: Convert arbitrary Perl Modules' versions into normalized Gentoo versions.
10              
11             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
12              
13 4     4   1930 use Sub::Exporter::Progressive -setup => { exports => [qw( gentooize_version )] };
  4         3732  
  4         35  
14 4     4   2038 use version 0.77;
  4         5895  
  4         23  
15              
16             sub gentooize_version {
17 68     68 1 16698 my ( $perlver, $config ) = @_;
18 68   100     270 $config ||= {};
19 68 100       133 if ( not defined $perlver ) {
20 1         3 return _err_perlver_undefined($config);
21             }
22 67 100       172 $config->{lax} = 0 unless defined $config->{lax};
23 67 50       111 if ( _env_hasopt('always_lax') ) {
24 0         0 $config->{lax} = _env_getopt('always_lax');
25             }
26              
27 67 100       337 if ( $perlver =~ /\Av?[\d.]+\z/msx ) {
28 46         77 return _lax_cleaning_0($perlver);
29             }
30              
31 21 100       72 if ( $perlver =~ /\Av?[\d._]+(-TRIAL)?\z/msx ) {
32 13 100       27 if ( $config->{lax} > 0 ) {
33 11         20 return _lax_cleaning_1($perlver);
34             }
35 2         5 return _err_matches_trial_regex_nonlax( $perlver, $config );
36             }
37              
38 8 100       19 if ( 2 == $config->{lax} ) {
39 6         13 return _lax_cleaning_2($perlver);
40             }
41 2         4 return _err_not_decimal_or_trial( $perlver, $config );
42             }
43              
44             ###
45             #
46             # character to code translation
47             #
48             ###
49              
50             ## no critic ( ProhibitMagicNumbers )
51             my $char_map = {
52             ( map { $_ => $_ } 0 .. 9 ), # 0..9
53             ( map { chr( $_ + 65 ) => $_ + 10 } 0 .. 25 ), # A-Z
54             ( map { chr( $_ + 97 ) => $_ + 10 } 0 .. 25 ), # a-z
55             };
56              
57             # _code_for('z') -> $number
58             #
59              
60             sub _code_for {
61 25     25   862 my $char = shift;
62 25 100       49 if ( not exists $char_map->{$char} ) {
63 1         2 my $char_ord = ord $char;
64 1         2 return _err_bad_char( $char, $char_ord );
65             }
66 24         56 return $char_map->{$char};
67             }
68              
69             ###
70             #
71             # Pair to number transformation.
72             #
73             # _enc_pair( 'x','y' ) -> $number
74             #
75             ##
76              
77             sub _enc_pair {
78 14     14   19 my (@tokens) = @_;
79 14 50       25 if ( not @tokens ) {
80 0         0 return q{};
81             }
82 14 100       21 if ( @tokens < 2 ) {
83 4         9 return _code_for( shift @tokens );
84             }
85 10         41 return ( _code_for( $tokens[0] ) * 36 ) + ( _code_for( $tokens[1] ) );
86             }
87              
88             ###
89             #
90             # String to dotted-decimal conversion
91             #
92             # $dotstring = _ascii_to_int("HELLOWORLD");
93             #
94             ###
95             sub _ascii_to_int {
96 6     6   7 my $string = shift;
97 6         12 my @chars = split //msx, $string;
98 6         6 my @output;
99              
100 6         11 while (@chars) {
101 14         23 push @output, _enc_pair( splice @chars, 0, 2, () );
102             }
103              
104 6         20 return join q{.}, @output;
105             }
106              
107             #
108             # Handler for gentooize_version( ... { lax => 0 } )
109             #
110             sub _lax_cleaning_0 {
111 46     46   44 my $version = shift;
112 46         73 return _expand_numeric($version);
113             }
114              
115             #
116             # Handler for gentooize_version( ... { lax => 1 } )
117             #
118              
119             sub _lax_cleaning_1 {
120 17     17   17 my $version = shift;
121 17         15 my $isdev = 0;
122 17         12 my $prereleasever = undef;
123              
124 17 100       43 if ( $version =~ s/-TRIAL\z//msx ) {
125 5         6 $isdev = 1;
126             }
127 17 100       47 if ( $version =~ s/_(.*)\z/$1/msx ) {
128 6         8 $prereleasever = "$1";
129 6         7 $isdev = 1;
130 6 100       14 if ( $prereleasever =~ /_/msx ) {
131 1         2 return _err_lax_multi_underscore($version);
132             }
133             }
134 16         23 $version = _expand_numeric($version);
135 16 100       26 if ($isdev) {
136 10         14 $version .= '_rc';
137             }
138 16         58 return $version;
139             }
140              
141             #
142             # Handler for gentooize_version( ... { lax => 2 } )
143             #
144              
145             sub _lax_cleaning_2 {
146 6     6   7 my $version = shift;
147 6         7 my $istrial = 0;
148              
149 6         4 my $has_v = 0;
150              
151 6 50       12 if ( $version =~ s/-TRIAL\z//msx ) {
152 0         0 $istrial = 1;
153             }
154 6 50       12 if ( $version =~ s/\Av//msx ) {
155 0         0 $has_v = 1;
156             }
157              
158 6         28 my @parts = split /([._])/msx, $version;
159 6         8 my @out;
160 6         9 for (@parts) {
161 30 100       46 if (/\A[_.]\z/msx) {
162 12         11 push @out, $_;
163 12         13 next;
164             }
165 18 100       31 if (/\A\d\z/msx) {
166 12         13 push @out, $_;
167 12         13 next;
168             }
169 6         10 push @out, _ascii_to_int($_);
170             }
171              
172 6         13 my $version_out = join q{}, @out;
173 6 50       9 if ($istrial) {
174 0         0 $version_out .= '-TRIAL';
175             }
176 6 50       11 if ($has_v) {
177 0         0 $version_out = 'v' . $version_out;
178             }
179 6         33 return _lax_cleaning_1($version_out);
180             }
181              
182             #
183             # Expands dotted decimal to a float, and then chunks the float.
184             #
185             # my $clean = _expand_numeric( $dirty );
186             #
187             sub _expand_numeric {
188 62     62   53 my $perlver = shift;
189              
190 62         601 my $ver = version->parse($perlver)->normal;
191              
192 62         254 $ver =~ s/\Av//msx; # strip leading v
193              
194 62         173 my @tokens = split /[.]/msx, $ver;
195 62         64 my @out;
196              
197 62         91 for (@tokens) {
198 203         171 s/\A0+([1-9])/$1/msx; # strip leading 0's
199 203         270 push @out, $_;
200             }
201              
202 62         350 return join q{.}, @out;
203             }
204              
205             BEGIN {
206 4     4   7 for my $err (qw( perlver_undefined matches_trial_regex_nonlax not_decimal_or_trial bad_char lax_multi_underscore )) {
207             my $code = sub {
208 7     7   639 require Gentoo::PerlMod::Version::Error;
209 7         48 my $sub = Gentoo::PerlMod::Version::Error->can($err);
210 7         19 goto $sub;
211 20         114 };
212             ## no critic ( ProhibitNoStrict )
213 4     4   3994 no strict 'refs';
  4         7  
  4         416  
214 20         15 *{ __PACKAGE__ . '::_err_' . $err } = $code;
  20         52  
215             }
216 4         6 for my $env (qw( opts hasopt getopt )) {
217             my $code = sub {
218 67     67   1456 require Gentoo::PerlMod::Version::Env;
219 67         292 my $sub = Gentoo::PerlMod::Version::Env->can($env);
220 67         174 goto $sub;
221 12         19 };
222             ## no critic ( ProhibitNoStrict )
223              
224 4     4   18 no strict 'refs';
  4         5  
  4         141  
225 12         36 *{ __PACKAGE__ . '::_env_' . $env } = $code;
  12         131  
226             }
227              
228             }
229              
230             1;
231              
232             __END__