Debbugs/Collection/Package.pm

   1 # This module is part of debbugs, and
   2 # is released under the terms of the GPL version 2, or any later
   3 # version (at your option). See the file README and COPYING for more
   4 # information.
   5 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   6
   7 package Debbugs::Collection::Package;
   8
   9 =head1 NAME
  10
  11 Debbugs::Collection::Package -- Package generation factory
  12
  13 =head1 SYNOPSIS
  14
  15 This collection extends L<Debbugs::Collection> and contains members of
  16 L<Debbugs::Package>. Useful for any field which contains one or more package or
  17 tracking lists of packages
  18
  19
  20 =head1 DESCRIPTION
  21
  22
  23
  24 =cut
  25
  26 use Mouse;
  27 use strictures 2;
  28 use v5.10; # for state
  29 use namespace::autoclean;
  30
  31 use Carp;
  32 use Debbugs::Common qw(make_list hash_slice);
  33 use Debbugs::Config qw(:config);
  34 use Debbugs::OOTypes;
  35 use Debbugs::Package;
  36
  37 use List::AllUtils qw(part);
  38
  39 use Debbugs::Version::Binary;
  40 use Debbugs::Collection::Version;
  41 use Debbugs::Collection::Correspondent;
  42 use Debbugs::VersionTree;
  43
  44 extends 'Debbugs::Collection';
  45
  46 =head1 Object Creation
  47
  48 =head2 my $packages = Debbugs::Collection::Package->new(%params|$param)
  49
  50 Parameters in addition to those defined by L<Debbugs::Collection>
  51
  52 =over
  53
  54 =item correspondent_collection
  55
  56 Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
  57
  58
  59 =item versiontree
  60
  61 Optional L<Debbugs::VersionTree> which contains known package source versions
  62
  63 =back
  64
  65 =head1 Methods
  66
  67 =head2 correspondent_collection
  68
  69      $packages->correspondent_collection
  70
  71 Returns the L<Debbugs::Collection::Correspondent> for this package collection
  72
  73 =head2 versiontree
  74
  75 Returns the L<Debbugs::VersionTree> for this package collection
  76
  77 =cut
  78
  79 has '+members' => (isa => 'ArrayRef[Debbugs::Package]');
  80
  81 sub BUILD {
  82     my $self = shift;
  83     my $args = shift;
  84     if (exists $args->{packages}) {
  85         $self->
  86             add($self->_member_constructor(packages =>
  87                                            $args->{packages}));
  88     }
  89 }
  90
  91 around add_by_key => sub {
  92     my $orig = shift;
  93     my $self = shift;
  94     my @members =
  95         $self->_member_constructor(packages => [@_]);
  96     return $self->$orig(@members);
  97 };
  98
  99 sub _member_constructor {
 100     # handle being called $self->_member_constructor;
 101     my $self = shift;
 102     my %args = @_;
 103     my $schema;
 104     if ($self->has_schema) {
 105         $schema = $self->schema;
 106     }
 107     my @return;
 108     if (defined $schema) {
 109         if (not ref($args{packages}) or @{$args{packages}} == 1 and
 110             $self->universe->count() > 0
 111            ) {
 112             carp("Likely inefficiency; member_constructor called with one argument");
 113         }
 114         my $packages =
 115             Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages},
 116                                                               schema => $schema,
 117                                                              );
 118         for my $package (keys %{$packages}) {
 119             push @return,
 120                 Debbugs::Package->new(%{$packages->{$package}},
 121                                       schema => $schema,
 122                                       package_collection => $self->universe,
 123                                       correspondent_collection =>
 124                                       $self->correspondent_collection->universe,
 125                                      );
 126         }
 127     } else {
 128         carp "No schema\n";
 129         for my $package (make_list($args{packages})) {
 130             push @return,
 131                 Debbugs::Package->new(name => $package,
 132                                       package_collection => $self->universe,
 133                                       correspondent_collection =>
 134                                       $self->correspondent_collection->universe,
 135                                      );
 136         }
 137     }
 138     return @return;
 139 }
 140
 141 sub add_packages_and_versions {
 142     my $self = shift;
 143     $self->add($self->_member_constructor(packages => \@_));
 144 }
 145
 146
 147 sub member_key {
 148     return $_[1]->qualified_name;
 149 }
 150
 151 has 'correspondent_collection' =>
 152     (is => 'ro',
 153      isa => 'Debbugs::Collection::Correspondent',
 154      default => sub {Debbugs::Collection::Correspondent->new()},
 155     );
 156
 157 has 'versiontree' =>
 158     (is => 'ro',
 159      isa => 'Debbugs::VersionTree',
 160      lazy => 1,
 161      builder => '_build_versiontree',
 162     );
 163
 164 sub _build_versiontree {
 165     my $self = shift;
 166     return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
 167 }
 168
 169 =head2 get_source_versions_distributions
 170
 171      $packages->get_source_versions_distributions('unstable')
 172
 173 Given a list of distributions or suites, returns a
 174 L<Debbugs::Collection::Version> of all of the versions in this package
 175 collection which are known to match.
 176
 177 Effectively, this calls L<Debbugs::Package/get_source_version_distribution> for
 178 each package in the collection and merges the results and returns them
 179
 180 =cut
 181
 182 sub get_source_versions_distributions {
 183     my $self = shift;
 184     my @return;
 185     push @return,
 186         $self->map(sub {$_->get_source_version_distribution(@_)});
 187     if (@return > 1) {
 188         return $return[0]->combine($return[1..$#return]);
 189     }
 190     return @return;
 191 }
 192
 193
 194 =head2 get_source_versions
 195
 196     $packages->get_source_versions('1.2.3-1','foo/1.2.3-5')
 197
 198 Given a list of binary versions or src/versions, returns a
 199 L<Debbugs::Collection::Version> of all of the versions in this package
 200 collection which are known to match.
 201
 202 If you give a binary version ('1.2.3-1'), you must have already loaded source
 203 packages into this package collection for it to find an appropriate match.
 204
 205 If no package is known to match, an version which is invalid will be returned
 206
 207 For fully qualified versions this loads the appropriate source package into the
 208 universe of this collection and calls L<Debbugs::Package/get_source_version>.
 209 For unqualified versions, calls L<Debbugs::Package/get_source_version>; if no
 210 valid versions are returned, creates an invalid version.
 211
 212 =cut
 213
 214 sub get_source_versions {
 215     my $self = shift;
 216     my @return;
 217     for my $ver (@_) {
 218         my $sv;
 219         if ($ver =~ m{(?<src>.+?)/(?<ver>.+)$}) {
 220             my $sp = $self->universe->
 221                 get_or_add_by_key('src:'.$+{src});
 222             push @return,
 223                 $sp->get_source_version($+{ver});
 224            next;
 225         } else {
 226             my $found_valid = 0;
 227             for my $p ($self->members) {
 228                 local $_;
 229                 my @vs =
 230                     grep {$_->is_valid}
 231                     $p->get_source_version($ver);
 232                 if (@vs) {
 233                     $found_valid = 1;
 234                     push @return,@vs;
 235                     next;
 236                 }
 237             }
 238             if (not $found_valid) {
 239                 push @return,
 240                     Debbugs::Version::Binary->new(version => $ver,
 241                                                   package_collection => $self->universe,
 242                                                   valid => 0,
 243                                                   $self->schema_argument,
 244                                                  );
 245             }
 246         }
 247     }
 248     return
 249         Debbugs::Collection::Version->new(members => \@return,
 250                                           $self->schema_argument,
 251                                           package_collection => $self->universe,
 252                                          );
 253 }
 254
 255 =head2 source_names
 256
 257      $packages->source_names()
 258
 259 Returns a unique list of source names from all members of this collection by
 260 calling L<Debbugs::Package/source_names> on each member.
 261
 262 =cut
 263
 264 sub source_names {
 265     my $self = shift;
 266     local $_;
 267     return uniq map {$_->source_names} $self->members;
 268 }
 269
 270 =head2 sources
 271
 272      $packages->sources()
 273
 274 Returns a L<Debbugs::Collection::Package> limited to source packages
 275 corresponding to all packages in this collection
 276
 277 =cut
 278
 279 sub sources {
 280     my $self = shift;
 281     return $self->universe->limit($self->source_names);
 282 }
 283
 284
 285 __PACKAGE__->meta->make_immutable;
 286 no Mouse;
 287
 288 1;
 289
 290 __END__
 291 # Local Variables:
 292 # indent-tabs-mode: nil
 293 # cperl-indent-level: 4
 294 # End: