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