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         for my $package (make_list($args{packages})) {
 129             push @return,
 130                 Debbugs::Package->new(name => $package,
 131                                       package_collection => $self->universe,
 132                                       correspondent_collection =>
 133                                       $self->correspondent_collection->universe,
 134                                      );
 135         }
 136     }
 137     return @return;
 138 }
 139
 140 sub add_packages_and_versions {
 141     my $self = shift;
 142     $self->add($self->_member_constructor(packages => \@_));
 143 }
 144
 145
 146 sub member_key {
 147     return $_[1]->qualified_name;
 148 }
 149
 150 has 'correspondent_collection' =>
 151     (is => 'ro',
 152      isa => 'Debbugs::Collection::Correspondent',
 153      default => sub {Debbugs::Collection::Correspondent->new()},
 154     );
 155
 156 has 'versiontree' =>
 157     (is => 'ro',
 158      isa => 'Debbugs::VersionTree',
 159      lazy => 1,
 160      builder => '_build_versiontree',
 161     );
 162
 163 sub _build_versiontree {
 164     my $self = shift;
 165     return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
 166 }
 167
 168 =head2 get_source_versions_distributions
 169
 170      $packages->get_source_versions_distributions('unstable')
 171
 172 Given a list of distributions or suites, returns a
 173 L<Debbugs::Collection::Version> of all of the versions in this package
 174 collection which are known to match.
 175
 176 Effectively, this calls L<Debbugs::Package/get_source_version_distribution> for
 177 each package in the collection and merges the results and returns them
 178
 179 =cut
 180
 181 sub get_source_versions_distributions {
 182     my $self = shift;
 183     my @return;
 184     push @return,
 185         $self->map(sub {$_->get_source_version_distribution(@_)});
 186     if (@return > 1) {
 187         return $return[0]->combine($return[1..$#return]);
 188     }
 189     return @return;
 190 }
 191
 192
 193 =head2 get_source_versions
 194
 195     $packages->get_source_versions('1.2.3-1','foo/1.2.3-5')
 196
 197 Given a list of binary versions or src/versions, returns a
 198 L<Debbugs::Collection::Version> of all of the versions in this package
 199 collection which are known to match.
 200
 201 If you give a binary version ('1.2.3-1'), you must have already loaded source
 202 packages into this package collection for it to find an appropriate match.
 203
 204 If no package is known to match, an version which is invalid will be returned
 205
 206 For fully qualified versions this loads the appropriate source package into the
 207 universe of this collection and calls L<Debbugs::Package/get_source_version>.
 208 For unqualified versions, calls L<Debbugs::Package/get_source_version>; if no
 209 valid versions are returned, creates an invalid version.
 210
 211 =cut
 212
 213 sub get_source_versions {
 214     my $self = shift;
 215     my @return;
 216     for my $ver (@_) {
 217         my $sv;
 218         if ($ver =~ m{(?<src>.+?)/(?<ver>.+)$}) {
 219             my $sp = $self->universe->
 220                 get_or_add_by_key('src:'.$+{src});
 221             push @return,
 222                 $sp->get_source_version($+{ver});
 223            next;
 224         } else {
 225             my $found_valid = 0;
 226             for my $p ($self->members) {
 227                 local $_;
 228                 my @vs =
 229                     grep {$_->is_valid}
 230                     $p->get_source_version($ver);
 231                 if (@vs) {
 232                     $found_valid = 1;
 233                     push @return,@vs;
 234                     next;
 235                 }
 236             }
 237             if (not $found_valid) {
 238                 push @return,
 239                     Debbugs::Version::Binary->new(version => $ver,
 240                                                   package_collection => $self->universe,
 241                                                   valid => 0,
 242                                                   $self->schema_argument,
 243                                                  );
 244             }
 245         }
 246     }
 247     return
 248         Debbugs::Collection::Version->new(members => \@return,
 249                                           $self->schema_argument,
 250                                           package_collection => $self->universe,
 251                                          );
 252 }
 253
 254 =head2 source_names
 255
 256      $packages->source_names()
 257
 258 Returns a unique list of source names from all members of this collection by
 259 calling L<Debbugs::Package/source_names> on each member.
 260
 261 =cut
 262
 263 sub source_names {
 264     my $self = shift;
 265     local $_;
 266     return uniq map {$_->source_names} $self->members;
 267 }
 268
 269 =head2 sources
 270
 271      $packages->sources()
 272
 273 Returns a L<Debbugs::Collection::Package> limited to source packages
 274 corresponding to all packages in this collection
 275
 276 =cut
 277
 278 sub sources {
 279     my $self = shift;
 280     return $self->universe->limit($self->source_names);
 281 }
 282
 283
 284 __PACKAGE__->meta->make_immutable;
 285 no Mouse;
 286
 287 1;
 288
 289 __END__
 290 # Local Variables:
 291 # indent-tabs-mode: nil
 292 # cperl-indent-level: 4
 293 # End: