lib/CPANPLUS/Dist/Gentoo/Atom.pm

   1 package CPANPLUS::Dist::Gentoo::Atom;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.08';
   7
   8 use Carp         ();
   9 use Scalar::Util ();
  10
  11 use overload (
  12  '<=>' => \&_spaceship,
  13  'cmp' => \&_cmp,
  14  '""'  => \&_stringify,
  15 );
  16
  17 use CPANPLUS::Dist::Gentoo::Version;
  18
  19 my $version_rx = $CPANPLUS::Dist::Gentoo::Version::version_rx;
  20
  21 sub new {
  22  my $class = shift;
  23  $class = ref($class) || $class;
  24
  25  my %args = @_;
  26
  27  my ($category, $name, $version);
  28  if (defined $args{name}) {
  29   ($category, $name, $version) = @args{qw/category name version/};
  30   Carp::confess('Category unspecified') unless defined $category;
  31   /[^\w-]/ and Carp::confess('Invalid argument') for $name, $category;
  32  } elsif (defined $args{atom}) {
  33   my $atom = $args{atom};
  34   $atom =~ m{^([\w-]+)/([\w-]+)-v?($version_rx)$}
  35                                                or Carp::confess('Invalid atom');
  36   ($category, $name, $version) = ($1, $2, $3);
  37  } else {
  38   Carp::confess('Not enough information for building an atom object');
  39  }
  40
  41  if (defined $version) {
  42   unless (Scalar::Util::blessed($version)
  43                               and $_->isa('CPANPLUS::Dist::Gentoo::Version')) {
  44    $version = CPANPLUS::Dist::Gentoo::Version->new($version);
  45   }
  46  }
  47
  48  my $range = $args{range};
  49  if (defined $version) {
  50   if (defined $range) {
  51    Carp::confess("Invalid range $range")
  52                                       unless grep $range eq $_, qw|< <= = >= >|;
  53   } else {
  54    $range = '=';
  55   }
  56  } else {
  57   Carp::confess('Range atoms require a valid version')
  58                                             if defined $range and length $range;
  59  }
  60
  61  bless {
  62   category => $category,
  63   name     => $name,
  64   version  => $version,
  65   range    => $range,
  66   ebuild   => $args{ebuild},
  67  }, $class;
  68 }
  69
  70 sub new_from_ebuild {
  71  my $class = shift;
  72  $class = ref($class) || $class;
  73
  74  my $ebuild = shift;
  75  $ebuild = '' unless defined $ebuild;
  76
  77  $ebuild =~ m{/([\w-]+)/([\w-]+)/\2-v?($version_rx)\.ebuild$}
  78                                              or Carp::confess('Invalid ebuild');
  79  my ($category, $name, $version) = ($1, $2, $3);
  80
  81  return $class->new(
  82   category => $category,
  83   name     => $name,
  84   version  => $version,
  85   ebuild   => $ebuild,
  86  );
  87 }
  88
  89 BEGIN {
  90  eval "sub $_ { \$_[0]->{$_} }" for qw/category name version range ebuild/;
  91 }
  92
  93 sub qualified_name { join '/', $_[0]->category, $_[0]->name }
  94
  95 sub _spaceship {
  96  my ($a1, $a2, $r) = @_;
  97
  98  my $v1 = $a1->version;
  99
 100  my $v2;
 101  if (Scalar::Util::blessed($a2) and $a2->isa(__PACKAGE__)) {
 102   Carp::confess('Can\'t compare atoms of different packages')
 103                     if $a1->category ne $a2->category or $a1->name ne $a2->name;
 104   $v2 = $a2->version;
 105  } else {
 106   $v2 = $a2;
 107  }
 108
 109  ($v1, $v2) = ($v2, $v1) if $r;
 110
 111  return $v1 <=> $v2;
 112 }
 113
 114 sub _cmp {
 115  my ($a1, $a2, $r) = @_;
 116
 117  my $s1 = $a1->qualified_name;
 118  my $v1 = $a1->version;
 119  $s1   .= "-$v1" if defined $v1;
 120
 121  my $s2;
 122  if (Scalar::Util::blessed($a2) and $a2->isa(__PACKAGE__)) {
 123   $s2    = $a2->qualified_name;
 124   my $v2 = $a2->version;
 125   $s2   .= "-$v2" if defined $v2;
 126  } else {
 127   $s2 = $a2;
 128  }
 129
 130  $s1 cmp $s2;
 131 }
 132
 133 sub _stringify {
 134  my ($a) = @_;
 135
 136  my $atom = $a->qualified_name;
 137
 138  my $version = $a->version;
 139  $atom = $a->range . $atom . '-' . $version if defined $version;
 140
 141  return $atom;
 142 }
 143
 144 my %order = (
 145  '<'  => -2,
 146  '<=' => -1,
 147   '=' =>  0,
 148  '>=' =>  1,
 149  '>'  =>  2,
 150 );
 151
 152 sub and {
 153  shift unless length ref $_[0];
 154
 155  my $a1 = shift;
 156  my $a2 = shift;
 157  $a2 = $a2->and(@_) if @_;
 158
 159  my $p1 = $a1->qualified_name;
 160  my $p2 = $a2->qualified_name;
 161  Carp::confess("Atoms for different packages $p1 and $p2") unless $p1 eq $p2;
 162
 163  my $v1 = $a1->version;
 164  return $a2 unless defined $v1;
 165  my $r1 = $a1->range; # Defined if $v1 is defined
 166
 167  my $v2 = $a2->version;
 168  return $a1 unless defined $v2;
 169  my $r2 = $a2->range; # defined if $v2 is defined
 170
 171  my $o1 = $order{$r1};
 172  my $o2 = $order{$r2};
 173
 174  Carp::confess("Incompatible ranges $r1$p1 and $r2$p2") if $o1 * $o2 < 0;
 175
 176  if ($r2 eq '=') {
 177   ($a1, $a2) = ($a2, $a1);
 178   ($v1, $v2) = ($v2, $v1);
 179   ($r1, $r2) = ($r2, $r1);
 180   ($o1, $o2) = ($o2, $o1);
 181  }
 182
 183  if ($r1 eq '=') {
 184   my $r = $r2 eq '=' ? '==' : $r2;
 185   Carp::confess("Version mismatch $v1 $r $v2") unless eval "\$a1 $r \$a2";
 186   return $a1;
 187  } elsif ($o1 > 0) {
 188   return $a1 < $a2 ? $a2 : $a1;
 189  } else {
 190   return $a1 < $a2 ? $a1 : $a2;
 191  }
 192 }
 193
 194 sub fold {
 195  shift unless length ref $_[0];
 196
 197  my %seen;
 198  for my $atom (@_) {
 199   my $key = $atom->qualified_name;
 200
 201   my $cur = $seen{$key};
 202   $seen{$key} = defined $cur ? $cur->and($atom) : $atom;
 203  }
 204
 205  return values %seen;
 206 }
 207
 208 1;