]> git.vpit.fr Git - perl/modules/CPANPLUS-Dist-Gentoo.git/blob - lib/CPANPLUS/Dist/Gentoo/Atom.pm
Add an EXPORT section to CPANPLUS::Dist::Gentoo::Maps
[perl/modules/CPANPLUS-Dist-Gentoo.git] / lib / CPANPLUS / Dist / Gentoo / Atom.pm
1 package CPANPLUS::Dist::Gentoo::Atom;
2
3 use strict;
4 use warnings;
5
6 =head1 NAME
7
8 CPANPLUS::Dist::Gentoo::Atom - Gentoo atom 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 atoms.
21
22 =cut
23
24 use Carp         ();
25 use Scalar::Util ();
26
27 use overload (
28  '<=>' => \&_spaceship,
29  'cmp' => \&_cmp,
30  '""'  => \&_stringify,
31 );
32
33 use CPANPLUS::Dist::Gentoo::Version;
34
35 my $range_rx    = qr/(?:<|<=|=|>=|>)/;
36 my $name_rx     = qr/[a-zA-Z0-9_+-]+/;
37 my $category_rx = $name_rx;
38 my $version_rx  = $CPANPLUS::Dist::Gentoo::Version::version_rx;
39
40 =head1 METHODS
41
42 =head2 C<new>
43
44     # Infer everything from $atom :
45     my $cdga = CPANPLUS::Dist::Gentoo::Atom->new(
46      atom     => $atom,
47      # Optional :
48      ebuild   => $ebuild,
49     );
50
51     # Or specify the attributes manually :
52     my $cdga = CPANPLUS::Dist::Gentoo::Atom->new(
53      category => $category,
54      name     => $name,
55      version  => $version,
56      range    => $range,
57      # Optional :
58      ebuild   => $ebuild,
59     );
60
61 Creates a new L<CPANPLUS::Dist::Gentoo::Atom> object from the supplied C<$category>, C<$name>, C<$version>, C<$range> and C<$ebuild>.
62
63 =cut
64
65 sub new {
66  my $class = shift;
67  $class = ref($class) || $class;
68
69  my %args = @_;
70
71  my ($range, $category, $name, $version);
72  if (defined $args{name}) {
73   ($range, $category, $name, $version) = @args{qw<range category name version>};
74   Carp::confess('Category unspecified') unless defined $category;
75   Carp::confess('Invalid category')     unless $category =~ /^$category_rx$/o;
76   Carp::confess('Invalid name')         unless $name     =~ /^$name_rx$/o;
77  } elsif (defined $args{atom}) {
78   my $atom = $args{atom};
79   $atom =~ m{^($range_rx)?($category_rx)/($name_rx)(?:-($version_rx))?$}o
80                                                or Carp::confess('Invalid atom');
81   ($range, $category, $name, $version) = ($1, $2, $3, $4);
82  } else {
83   Carp::confess('Not enough information for building an atom object');
84  }
85
86  if (defined $version) {
87   unless (Scalar::Util::blessed($version)
88           and $version->isa('CPANPLUS::Dist::Gentoo::Version')) {
89    $version = CPANPLUS::Dist::Gentoo::Version->new($version);
90   }
91  }
92
93  if (defined $version) {
94   if (defined $range) {
95    Carp::confess("Invalid range $range") unless $range =~ /^$range_rx$/o;
96   } else {
97    $range = '>=';
98   }
99  } else {
100   Carp::confess('Range atoms require a valid version')
101                                             if defined $range and length $range;
102  }
103
104  bless {
105   category => $category,
106   name     => $name,
107   version  => $version,
108   range    => $range,
109   ebuild   => $args{ebuild},
110  }, $class;
111 }
112
113 =head2 C<new_from_ebuild>
114
115     my $cdga = CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($ebuild);
116
117 Creates a new L<CPANPLUS::Dist::Gentoo::Atom> object by inferring the category, name and version from the given C<$ebuild>
118
119 =cut
120
121 sub new_from_ebuild {
122  my $class = shift;
123  $class = ref($class) || $class;
124
125  my $ebuild = shift;
126  $ebuild = '' unless defined $ebuild;
127
128  $ebuild =~ m{/($category_rx)/($name_rx)/\2-($version_rx)\.ebuild$}o
129                                              or Carp::confess('Invalid ebuild');
130  my ($category, $name, $version) = ($1, $2, $3);
131
132  return $class->new(
133   category => $category,
134   name     => $name,
135   version  => $version,
136   ebuild   => $ebuild,
137  );
138 }
139
140 BEGIN {
141  eval "sub $_ { \$_[0]->{$_} }" for qw<category name version range ebuild>;
142 }
143
144 =head2 C<category>
145
146 Read-only accessor to the atom category.
147
148 =head2 C<name>
149
150 Read-only accessor to the atom name.
151
152 =head2 C<version>
153
154 Read-only accessor to the L<CPANPLUS::Dist::Gentoo::Version> object associated with the atom.
155
156 =head2 C<range>
157
158 Read-only accessor to the atom range.
159
160 =head2 C<ebuild>
161
162 Read-only accessor to the path of an optional ebuild associated with the atom.
163
164 =head2 C<qualified_name>
165
166 Returns the qualified name for the atom, i.e. C<$category/$name>.
167
168 =cut
169
170 sub qualified_name { join '/', $_[0]->category, $_[0]->name }
171
172 sub _spaceship {
173  my ($a1, $a2, $r) = @_;
174
175  my $v1 = $a1->version;
176
177  my $v2;
178  my $blessed = Scalar::Util::blessed($a2);
179  unless ($blessed and $a2->isa(__PACKAGE__)) {
180   if ($blessed and $a2->isa('CPANPLUS::Dist::Gentoo::Version')) {
181    $v2 = $a2;
182    $a2 = undef;
183   } else {
184    my $maybe_atom = eval { __PACKAGE__->new(atom => $a2) };
185    if (my $err = $@) {
186     $v2 = eval { CPANPLUS::Dist::Gentoo::Version->new($a2) };
187     Carp::confess("Can't compare an atom against something that's not an atom, an atom string ($err), a version or a version string ($@)") if $@;
188     $a2 = undef;
189    } else {
190     $a2 = $maybe_atom;
191    }
192   }
193  }
194
195  if (defined $a2) {
196   $v2 = $a2->version;
197
198   my $p1 = $a1->qualified_name;
199   my $p2 = $a2->qualified_name;
200   Carp::confess("Atoms for different packages $p1 and $p2") unless $p1 eq $p2;
201  }
202
203  ($v1, $v2) = ($v2, $v1) if $r;
204
205  return (defined $v1 or 0) <=> (defined $v2 or 0) unless defined $v1
206                                                      and defined $v2;
207
208  return $v1 <=> $v2;
209 }
210
211 sub _cmp {
212  my ($a1, $a2, $r) = @_;
213
214  if (defined $a2) {
215   my $p1 = $a1->qualified_name;
216
217   unless (Scalar::Util::blessed($a2) && $a2->isa(__PACKAGE__)) {
218    $a2 = eval { __PACKAGE__->new(atom => $a2) };
219    Carp::confess("Can't compare an atom against something that's not an atom or an atom string ($@)") if $@;
220   }
221   my $p2 = $a2->qualified_name;
222
223   if (my $c = $p1 cmp $p2) {
224    return $r ? -$c : $c;
225   }
226  }
227
228  $a1 <=> $a2;
229 }
230
231 sub _stringify {
232  my ($a) = @_;
233
234  my $atom = $a->qualified_name;
235
236  my $version = $a->version;
237  $atom = $a->range . $atom . '-' . $version if defined $version;
238
239  return $atom;
240 }
241
242 my %order = (
243  '<'  => -2,
244  '<=' => -1,
245   '=' =>  0,
246  '>=' =>  1,
247  '>'  =>  2,
248 );
249
250 =head2 C<and>
251
252     my $cdga = CPANPLUS::Dist::Gentoo::Atom->and(@atoms);
253
254 Compute the ranged atom representing the logical AND between C<@atoms> with the same category and name.
255
256 =cut
257
258 sub and {
259  shift unless length ref $_[0];
260
261  my $a1 = shift;
262  return $a1 unless @_;
263
264  my $a2 = shift;
265  $a2 = $a2->and(@_) if @_;
266
267  my $p1 = $a1->qualified_name;
268  my $p2 = $a2->qualified_name;
269  Carp::confess("Atoms for different packages $p1 and $p2") unless $p1 eq $p2;
270
271  my $v1 = $a1->version;
272  return $a2 unless defined $v1;
273  my $r1 = $a1->range; # Defined if $v1 is defined
274
275  my $v2 = $a2->version;
276  return $a1 unless defined $v2;
277  my $r2 = $a2->range; # defined if $v2 is defined
278
279  my $o1 = $order{$r1};
280  my $o2 = $order{$r2};
281
282  Carp::confess("Incompatible ranges $r1$p1 and $r2$p2") if $o1 * $o2 < 0;
283
284  if ($r2 eq '=') {
285   ($a1, $a2) = ($a2, $a1);
286   ($v1, $v2) = ($v2, $v1);
287   ($r1, $r2) = ($r2, $r1);
288   ($o1, $o2) = ($o2, $o1);
289  }
290
291  if ($r1 eq '=') {
292   my $r = $r2 eq '=' ? '==' : $r2;
293   Carp::confess("Version mismatch $v1 $r $v2") unless eval "\$a1 $r \$a2";
294   return $a1;
295  } elsif ($o1 > 0) {
296   return $a1 < $a2 ? $a2 : $a1;
297  } else {
298   return $a1 < $a2 ? $a1 : $a2;
299  }
300 }
301
302 =head2 C<fold>
303
304     my @folded = CPANPLUS::Dist::Gentoo::Atom->fold(@atoms);
305
306 Returns a list built from C<@atoms> but where there's only one atom for a given category and name.
307
308 =cut
309
310 sub fold {
311  shift unless length ref $_[0];
312
313  my %seen;
314  for my $atom (@_) {
315   my $key = $atom->qualified_name;
316
317   my $cur = $seen{$key};
318   $seen{$key} = defined $cur ? $cur->and($atom) : $atom;
319  }
320
321  return map $seen{$_}, sort keys %seen;
322 }
323
324 =pod
325
326 This class provides overloaded methods for numerical comparison, string comparison and stringification.
327
328 =head1 SEE ALSO
329
330 L<CPANPLUS::Dist::Gentoo>, L<CPANPLUS::Dist::Gentoo::Version>.
331
332 =head1 AUTHOR
333
334 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
335
336 You can contact me by mail or on C<irc.perl.org> (vincent).
337
338 =head1 BUGS
339
340 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>.
341 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
342
343 =head1 SUPPORT
344
345 You can find documentation for this module with the perldoc command.
346
347     perldoc CPANPLUS::Dist::Gentoo
348
349 =head1 COPYRIGHT & LICENSE
350
351 Copyright 2009,2010,2011,2012 Vincent Pit, all rights reserved.
352
353 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
354
355 =cut
356
357 1; # End of CPANPLUS::Dist::Gentoo::Atom