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