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.11
  13
  14 =cut
  15
  16 our $VERSION = '0.11';
  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 and @b) {
 130    my $x = shift @a;
 131    my $y = shift @b;
 132    my $c = $x <=> $y;
 133    return $c if $c;
 134   }
 135
 136   return  1 if @a;
 137   return -1 if @b;
 138  }
 139
 140  {
 141   my ($l1, $l2) = map { defined() ? ord : 0 } map $_->letter, $v1, $v2;
 142
 143   my $c = $l1 <=> $l2;
 144   return $c if $c;
 145  }
 146
 147  {
 148   my @a = @{ $v1->suffixes };
 149   my @b = @{ $v2->suffixes };
 150
 151   while (@a or @b) {
 152    my $x = $suffix_grade{ shift(@a) || 'normal' };
 153    my $y = $suffix_grade{ shift(@b) || 'normal' };
 154    my $c = $x <=> $y;
 155    return $c if $c;
 156
 157    $x = shift(@a) || 0;
 158    $y = shift(@b) || 0;
 159    $c = $x <=> $y;
 160    return $c if $c;
 161   }
 162  }
 163
 164  {
 165   my ($r1, $r2) = map { defined() ? $_ : 0 } map $_->revision, $v1, $v2;
 166
 167   my $c = $r1 <=> $r2;
 168   return $c if $c;
 169  }
 170
 171  return 0;
 172 }
 173
 174 sub _stringify {
 175  my ($v) = @_;
 176
 177  my ($version, $letter, $suffixes, $revision) = map $v->$_, @parts;
 178  my @suffixes = @$suffixes;
 179
 180  $version   = join '.', @$version;
 181  $version  .= $letter if defined $letter;
 182  while (my @suffix = splice @suffixes, 0, 2) {
 183   my $s = $suffix[0];
 184   my $n = $suffix[1];
 185   $version .= "_$s" . (defined $n ? $n : '');
 186  }
 187  $version .= "-r$revision" if defined $revision;
 188
 189  $version;
 190 }
 191
 192 =pod
 193
 194 This class provides overloaded methods for numerical comparison and stringification.
 195
 196 =head1 SEE ALSO
 197
 198 L<CPANPLUS::Dist::Gentoo>.
 199
 200 =head1 AUTHOR
 201
 202 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 203
 204 You can contact me by mail or on C<irc.perl.org> (vincent).
 205
 206 =head1 BUGS
 207
 208 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>.
 209 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 210
 211 =head1 SUPPORT
 212
 213 You can find documentation for this module with the perldoc command.
 214
 215     perldoc CPANPLUS::Dist::Gentoo
 216
 217 =head1 COPYRIGHT & LICENSE
 218
 219 Copyright 2009,2010 Vincent Pit, all rights reserved.
 220
 221 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 222
 223 =cut
 224
 225 1; # End of CPANPLUS::Dist::Gentoo::Version