]> git.vpit.fr Git - perl/modules/CPANPLUS-Dist-Gentoo.git/blob - Version.pm
bce74eadd906bac4f472bf34817035d8a1016682
[perl/modules/CPANPLUS-Dist-Gentoo.git] / Version.pm
1 package CPANPLUS::Dist::Gentoo::Version;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 CPANPLUS::Dist::Gentoo::Version - Gentoo version object.
9
10 =head1 VERSION
11
12 Version 0.10
13
14 =cut
15
16 our $VERSION = '0.10';
17
18 =head1 DESCRIPTION
19
20 This class models Gentoo versions as described in L<http://devmanual.gentoo.org/ebuild-writing/file-format/index.html>.
21
22 =cut
23
24 use Scalar::Util ();
25
26 use overload (
27  '<=>' => \&_spaceship,
28  '""'  => \&_stringify,
29 );
30
31 my $int_rx          = qr/[0-9]+/;
32 my $positive_int_rx = qr/0*[1-9][0-9]*/;
33 my $letter_rx       = qr/[a-zA-Z]/;
34 my $dotted_num_rx   = qr/$int_rx(?:\.$int_rx)*/o;
35
36 my @suffixes  = qw(alpha beta pre rc normal p);
37 my $suffix_rx = join '|', grep !/^normal$/, @suffixes;
38 $suffix_rx    = qr/(?:$suffix_rx)/o;
39
40 our $version_rx = qr{
41  $dotted_num_rx $letter_rx?
42  (?:_$suffix_rx$positive_int_rx?)*
43  (?:-r$positive_int_rx)?
44 }xo;
45
46 my $capturing_version_rx = qr{
47  ($dotted_num_rx) ($letter_rx)?
48  ((?:_$suffix_rx$positive_int_rx?)*)
49  (?:-r($positive_int_rx))?
50 }xo;
51
52 =head1 METHODS
53
54 =head2 C<new $vstring>
55
56 Creates a new L<CPANPLUS::Dist::Gentoo::Version> object from the version string C<$vstring>.
57
58 =cut
59
60 sub new {
61  my $class = shift;
62  $class = ref($class) || $class;
63
64  my $vstring = shift;
65  if (defined $vstring) {
66   $vstring =~ s/^[._]+//g;
67   $vstring =~ s/[._]+$//g;
68
69   if ($vstring =~ /^$capturing_version_rx$/o) {
70    return bless {
71     string   => $vstring,
72     version  => [ split /\.+/, $1 ],
73     letter   => $2,
74     suffixes => [ map /_($suffix_rx)($positive_int_rx)?/go, $3 ],
75     revision => $4,
76    }, $class;
77   }
78
79   require Carp;
80   Carp::croak("Couldn't parse version string '$vstring'");
81  }
82
83  require Carp;
84  Carp::croak('You must specify a version string');
85 }
86
87 my @parts;
88 BEGIN {
89  @parts = qw/version letter suffixes revision/;
90  eval "sub $_ { \$_[0]->{$_} }" for @parts;
91 }
92
93 =head2 C<version>
94
95 Read-only accessor for the C<version> part of the version object.
96
97 =head2 C<letter>
98
99 Read-only accessor for the C<letter> part of the version object.
100
101 =head2 C<suffixes>
102
103 Read-only accessor for the C<suffixes> part of the version object.
104
105 =head2 C<revision>
106
107 Read-only accessor for the C<revision> part of the version object.
108
109 =cut
110
111 my %suffix_grade = do {
112  my $i = 0;
113  map { $_ => ++$i } @suffixes;
114 };
115
116 sub _spaceship {
117  my ($v1, $v2, $r) = @_;
118
119  unless (Scalar::Util::blessed($v2) and $v2->isa(__PACKAGE__)) {
120   $v2 = $v1->new($v2);
121  }
122
123  ($v1, $v2) = ($v2, $v1) if $r;
124
125  {
126   my @a = @{ $v1->version };
127   my @b = @{ $v2->version };
128
129   while (@a or @b) {
130    my $x = shift(@a) || 0;
131    my $y = shift(@b) || 0;
132    my $c = $x <=> $y;
133    return $c if $c;
134   }
135  }
136
137  {
138   my ($l1, $l2) = map { defined() ? ord : 0 } map $_->letter, $v1, $v2;
139
140   my $c = $l1 <=> $l2;
141   return $c if $c;
142  }
143
144  {
145   my @a = @{ $v1->suffixes };
146   my @b = @{ $v2->suffixes };
147
148   while (@a or @b) {
149    my $x = $suffix_grade{ shift(@a) || 'normal' };
150    my $y = $suffix_grade{ shift(@b) || 'normal' };
151    my $c = $x <=> $y;
152    return $c if $c;
153
154    $x = shift(@a) || 0;
155    $y = shift(@b) || 0;
156    $c = $x <=> $y;
157    return $c if $c;
158   }
159  }
160
161  {
162   my ($r1, $r2) = map { defined() ? $_ : 0 } map $_->revision, $v1, $v2;
163
164   my $c = $r1 <=> $r2;
165   return $c if $c;
166  }
167
168  return 0;
169 }
170
171 sub _stringify {
172  my ($v) = @_;
173
174  my ($version, $letter, $suffixes, $revision) = map $v->$_, @parts;
175  my @suffixes = @$suffixes;
176
177  $version   = join '.', @$version;
178  $version  .= $letter if defined $letter;
179  while (my @suffix = splice @suffixes, 0, 2) {
180   my $s = $suffix[0];
181   my $n = $suffix[1];
182   $version .= "_$s" . (defined $n ? $n : '');
183  }
184  $version .= "-r$revision" if defined $revision;
185
186  $version;
187 }
188
189 =pod
190
191 This class provides overloaded methods for numerical comparison and strigification.
192
193 =head1 SEE ALSO
194
195 L<CPANPLUS::Dist::Gentoo>.
196
197 =head1 AUTHOR
198
199 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
200
201 You can contact me by mail or on C<irc.perl.org> (vincent).
202
203 =head1 BUGS
204
205 Please report any bugs or feature requests to C<bug-cpanplus-dist-gentoo at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CPANPLUS-Dist-Gentoo>.
206 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
207
208 =head1 SUPPORT
209
210 You can find documentation for this module with the perldoc command.
211
212     perldoc CPANPLUS::Dist::Gentoo
213
214 =head1 COPYRIGHT & LICENSE
215
216 Copyright 2009,2010 Vincent Pit, all rights reserved.
217
218 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
219
220 =cut
221
222 1; # End of CPANPLUS::Dist::Gentoo::Version