File Coverage

blib/lib/version/AlphaBeta.pm
Criterion Covered Total %
statement 68 71 95.7
branch 27 42 64.2
condition 6 12 50.0
subroutine 13 13 100.0
pod 4 6 66.6
total 118 144 81.9


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             package version::AlphaBeta;
3              
4 2     2   53644 use 5.005_03;
  2         8  
  2         101  
5 2     2   10 use strict;
  2         3  
  2         62  
6 2     2   1632 use version;
  2         4330  
  2         12  
7 2     2   106 use Exporter;
  2         3  
  2         122  
8              
9             use overload (
10 2         19 '""' => \&stringify,
11             '<=>' => \&spaceship,
12             'cmp' => \&spaceship,
13 2     2   3243 );
  2         2235  
14              
15 2     2   163 use vars qw($VERSION %IB %OB $TYPE);
  2         6  
  2         151  
16              
17 2     2   11 use base qw(version);
  2         2  
  2         1645  
18              
19             $VERSION = '0.06';
20              
21             %IB = (
22             'a' => -3,
23             'b' => -2,
24             'rc'=> -1,
25             '' => 0,
26             'pl'=> 1
27             );
28              
29             %OB = reverse %IB;
30              
31             $TYPE = join( "|", grep { $_ } keys(%IB) );
32              
33             # Preloaded methods go here.
34              
35             sub new {
36 27     27 0 1916 my $proto = shift;
37 27   66     114 my $class = ref($proto) || $proto;
38 27 100       58 my $parent = $proto if ref($proto);
39 27         35 my $ival = shift;
40              
41 27         335 my @value = ( grep { defined $_ }
  76         154  
42             ($ival =~
43             /^v? # optional prefix
44             (\d+) # Major
45             \. # Seperator
46             (\d+) # Minor
47             (?!\.) # No seperator here
48             ($TYPE)? # Type
49             (\d+)? # Subversion
50             $/x)
51             );
52              
53 27 100 66     181 die "Illegal version string format: \"$ival\""
54             unless scalar(@value) >= 2 # something matched
55             and scalar(@value) <= 4;# but not too much
56              
57 19 0 33     301 die "Illegal version string format: \"$ival\""
      33        
58             if $value[0] == 0 and $value[1] == 0
59             and defined $value[2]; # cannot be 0.0b1
60              
61             $value[2] = $IB{
62 19 100       59 (defined $value[2] ? $value[2] : "")
63             };
64              
65 19         42 my $self = \@value;
66 19         42 bless $self, $class;
67              
68 19         63 return $self;
69             }
70              
71             sub stringify {
72 20     20 1 193 my $self = shift;
73 20         51 my @values = @$self;
74              
75 20 50       63 $values[2] = $OB{$values[2]} if defined $values[2];
76 20 50       61 my $fmt = "%d.%d".
    50          
77             (defined $values[2] ? "%s" : "").
78             (defined $values[3] ? "%d" : "");
79 20         131 return sprintf($fmt,@values);
80             }
81              
82             sub numify {
83 8     8 1 13 my $self = shift;
84 8         60 my @values = @$self;
85              
86 8 50       23 $values[1] *= ($values[1] < 10 ? 100 : 10); # 3 decimal-places needed
87 8 50       17 if ( defined $values[2] ) { # need to handle specially
88 8 100       20 if ($values[2] < 0 ) {
89 6         6 $values[2] += 1000;
90 6         11 $values[1] -= 1;
91             }
92 8 50       15 if ($values[1] < 0 ) {
93 0         0 $values[1] += 1000;
94 0         0 $values[0] -= 1;
95             }
96             }
97 8 50       28 if ( defined $values[3] ) {
98 0 0       0 $values[3] *= ($values[3] < 10 ? 100 : 10); # 3 decimal-places
99             }
100              
101 8 50       29 my $fmt = "%d.%03d".
    50          
102             (defined $values[2] ? "%03d" : "").
103             (defined $values[3] ? "%03d" : "");
104 8         51 return sprintf($fmt,@values);
105             }
106              
107             sub spaceship {
108 20     20 0 2834 my ($left, $right, $swap) = @_;
109 20         25 my $test;
110            
111 20 100       124 unless ( UNIVERSAL::isa($right, ref($left)) ) {
112             # try to bless $right into our class
113 14         24 eval {
114 14         30 $right = $left->new($right);
115             };
116 14 100       34 if ($@) {
117 4         28 return -1;
118             }
119             }
120              
121 16 50       59 my $max = $#$left > $#$right ? $#$left : $#$right;
122              
123 16         44 for ( my $i=0; $i <= $max; $i++ ) {
124 48         76 $test = $$left[$i] <=> $$right[$i];
125 48 100       77 $test *= -1 if $swap;
126 48 100       170 return $test if $test;
127             }
128              
129 8         12 $test = $#$left <=> $#$right;
130 8 50       17 $test *= -1 if $swap;
131              
132 8         98 return $test;
133             }
134              
135             sub is_alpha {
136 2     2 1 4 my $self = shift;
137              
138 2         10 return ($$self[2] == $IB{'a'});
139             }
140              
141             sub is_beta {
142 2     2 1 5 my $self = shift;
143              
144 2         10 return ($$self[2] == $IB{'b'});
145             }
146              
147             1;
148             __END__