File Coverage

blib/lib/CPAN/Version.pm
Criterion Covered Total %
statement 56 66 84.8
branch 22 36 61.1
condition 15 19 78.9
subroutine 9 10 90.0
pod 0 8 0.0
total 102 139 73.3


line stmt bran cond sub pod time code
1             package CPAN::Version;
2              
3 13     13   554 use strict;
  13         15  
  13         468  
4 13     13   53 use vars qw($VERSION);
  13         15  
  13         18598  
5             $VERSION = "5.5003";
6              
7             # CPAN::Version::vcmp courtesy Jost Krieger
8             sub vcmp {
9 145     145 0 3012 my($self,$l,$r) = @_;
10 145         220 local($^W) = 0;
11 145 50       212 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
12              
13             # treat undef as zero
14 145 100       218 $l = 0 if $l eq 'undef';
15 145 100       192 $r = 0 if $r eq 'undef';
16              
17 145 100       179 return 0 if $l eq $r; # short circuit for quicker success
18              
19 139         143 for ($l,$r) {
20 278         350 s/_//g;
21             }
22 139 50       215 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
23 139         128 for ($l,$r) {
24 278 100 100     879 next unless tr/.// > 1 || /^v/;
25 106         272 s/^v?/v/;
26 106         333 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group
27             }
28 139 50       211 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
29 139 100       305 if ($l=~/^v/ <=> $r=~/^v/) {
30 76         77 for ($l,$r) {
31 152 100       272 next if /^v/;
32 76         109 $_ = $self->float2vv($_);
33             }
34             }
35 139 50       194 CPAN->debug("l[$l] r[$r]") if $CPAN::DEBUG;
36 139         117 my $lvstring = "v0";
37 139         103 my $rvstring = "v0";
38 139 100 66     667 if ($] >= 5.006
      66        
39             && $l =~ /^v/
40             && $r =~ /^v/) {
41 91         131 $lvstring = $self->vstring($l);
42 91         146 $rvstring = $self->vstring($r);
43 91 50       150 CPAN->debug(sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring) if $CPAN::DEBUG;
44             }
45              
46             return (
47 139   100     901 ($l ne "undef") <=> ($r ne "undef")
48             ||
49             $lvstring cmp $rvstring
50             ||
51             $l <=> $r
52             ||
53             $l cmp $r
54             );
55             }
56              
57             sub vgt {
58 61     61 0 1403 my($self,$l,$r) = @_;
59 61         84 $self->vcmp($l,$r) > 0;
60             }
61              
62             sub vlt {
63 22     22 0 44 my($self,$l,$r) = @_;
64 22         26 $self->vcmp($l,$r) < 0;
65             }
66              
67             sub vge {
68 2     2 0 10 my($self,$l,$r) = @_;
69 2         13 $self->vcmp($l,$r) >= 0;
70             }
71              
72             sub vle {
73 0     0 0 0 my($self,$l,$r) = @_;
74 0         0 $self->vcmp($l,$r) <= 0;
75             }
76              
77             sub vstring {
78 182     182 0 155 my($self,$n) = @_;
79 182 50       405 $n =~ s/^v// or die "CPAN::Version::vstring() called with invalid arg [$n]";
80 182         483 pack "U*", split /\./, $n;
81             }
82              
83             # vv => visible vstring
84             sub float2vv {
85 76     76 0 108 my($self,$n) = @_;
86 76         120 my($rev) = int($n);
87 76   100     125 $rev ||= 0;
88 76         170 my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit
89             # architecture influence
90 76   100     127 $mantissa ||= 0;
91 76         184 $mantissa .= "0" while length($mantissa)%3;
92 76         80 my $ret = "v" . $rev;
93 76         114 while ($mantissa) {
94 120 50       290 $mantissa =~ s/(\d{1,3})// or
95             die "Panic: length>0 but not a digit? mantissa[$mantissa]";
96 120         244 $ret .= ".".int($1);
97             }
98             # warn "n[$n]ret[$ret]";
99 76         112 $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0
100 76         149 $ret;
101             }
102              
103             sub readable {
104 1     1 0 3 my($self,$n) = @_;
105 1         5 $n =~ /^([\w\-\+\.]+)/;
106              
107 1 50 33     9 return $1 if defined $1 && length($1)>0;
108             # if the first user reaches version v43, he will be treated as "+".
109             # We'll have to decide about a new rule here then, depending on what
110             # will be the prevailing versioning behavior then.
111              
112 0 0         if ($] < 5.006) { # or whenever v-strings were introduced
113             # we get them wrong anyway, whatever we do, because 5.005 will
114             # have already interpreted 0.2.4 to be "0.24". So even if he
115             # indexer sends us something like "v0.2.4" we compare wrongly.
116              
117             # And if they say v1.2, then the old perl takes it as "v12"
118              
119 0 0         if (defined $CPAN::Frontend) {
120 0           $CPAN::Frontend->mywarn("Suspicious version string seen [$n]\n");
121             } else {
122 0           warn("Suspicious version string seen [$n]\n");
123             }
124 0           return $n;
125             }
126 0           my $better = sprintf "v%vd", $n;
127 0 0         CPAN->debug("n[$n] better[$better]") if $CPAN::DEBUG;
128 0           return $better;
129             }
130              
131             1;
132              
133             __END__