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 =head2 my $packages = Debbugs::Collection::Package->new(%params|$param)
  47
  48 Parameters in addition to those defined by L<Debbugs::Collection>
  49
  50 =over
  51
  52 =item correspondent_collection
  53
  54 Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
  55
  56
  57 =item versiontree
  58
  59 Optional L<Debbugs::VersionTree> which contains known package source versions
  60
  61 =back
  62
  63 =head2 $packages->correspondent_collection
  64
  65 Returns the L<Debbugs::Collection::Correspondent> for this package collection
  66
  67 =head2 versiontree
  68
  69 Returns the L<Debbugs::VersionTree> for this package collection
  70
  71 =head2 $packages->get_source_versions_distributions(@distributions)
  72
  73 Returns a L<Debbugs::Collection::Version> of all versions in this package
  74 collection which belong to the distributions given.
  75
  76 =head2 $packages->get_source_versions('1.2.3-1','foo/1.2.3-5')
  77
  78 Given a list of binary versions or src/versions, returns a
  79 L<Debbugs::Collection::Version> of all of the versions in this package
  80 collection which are known to match. You'll have to be sure to load appropriate
  81 versions beforehand for this to actually work.
  82
  83 =cut
  84
  85 has '+members' => (isa => 'ArrayRef[Debbugs::Package]');
  86
  87 sub BUILD {
  88     my $self = shift;
  89     my $args = shift;
  90     if (exists $args->{packages}) {
  91         $self->
  92             add($self->_member_constructor(packages =>
  93                                            $args->{packages}));
  94     }
  95 }
  96
  97 around add_by_key => sub {
  98     my $orig = shift;
  99     my $self = shift;
 100     my @members =
 101         $self->_member_constructor(packages => [@_]);
 102     return $self->$orig(@members);
 103 };
 104
 105 sub _member_constructor {
 106     # handle being called $self->_member_constructor;
 107     my $self = shift;
 108     my %args = @_;
 109     my $schema;
 110     if ($self->has_schema) {
 111         $schema = $self->schema;
 112     }
 113     my @return;
 114     if (defined $schema) {
 115         if (not ref($args{packages}) or @{$args{packages}} == 1 and
 116             $self->universe->count() > 0
 117            ) {
 118             carp("Likely inefficiency; member_constructor called with one argument");
 119         }
 120         my $packages =
 121             Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages},
 122                                                               schema => $schema,
 123                                                              );
 124         for my $package (keys %{$packages}) {
 125             push @return,
 126                 Debbugs::Package->new(%{$packages->{$package}},
 127                                       schema => $schema,
 128                                       package_collection => $self->universe,
 129                                       correspondent_collection =>
 130                                       $self->correspondent_collection->universe,
 131                                      );
 132         }
 133     } else {
 134         carp "No schema\n";
 135         for my $package (make_list($args{packages})) {
 136             push @return,
 137                 Debbugs::Package->new(name => $package,
 138                                       package_collection => $self->universe,
 139                                       correspondent_collection =>
 140                                       $self->correspondent_collection->universe,
 141                                      );
 142         }
 143     }
 144     return @return;
 145 }
 146
 147 sub add_packages_and_versions {
 148     my $self = shift;
 149     $self->add($self->_member_constructor(packages => \@_));
 150 }
 151
 152 # state $common_dists = [@{$config{distributions}}];
 153 # sub _get_packages {
 154 #     my %args = @_;
 155 #     my $s = $args{schema};
 156 #     my %src_packages;
 157 #     my %src_ver_packages;
 158 #     my %bin_packages;
 159 #     my %bin_ver_packages;
 160 #     # split packages into src/ver, bin/ver, src, and bin so we can select them
 161 #     # from the database
 162 #     local $_;
 163 #     for my $pkg (@{$args{packages}}) {
 164 #         if (ref($pkg)) {
 165 #             if ($pkg->[0] =~ /^src:(.+)$/) {
 166 #                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 167 #                     $src_ver_packages{$1}{$ver} = 1;
 168 #                 }
 169 #             } else {
 170 #                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 171 #                     $bin_ver_packages{$pkg->[0]}{$ver} = 1;
 172 #                 }
 173 #             }
 174 #         } elsif ($pkg =~ /^src:(.+)$/) {
 175 #             $src_packages{$1} = 1;
 176 #         } else {
 177 #             $bin_packages{$pkg} = 1;
 178 #         }
 179 #     }
 180 #     my @src_ver_search;
 181 #     for my $sp (keys %src_ver_packages) {
 182 #         push @src_ver_search,
 183 #             (-and => {'src_pkg.pkg' => $sp,
 184 #                       'me.ver' => [keys %{$src_ver_packages{$sp}}],
 185 #                      },
 186 #              );
 187 #     }
 188 #     my %packages;
 189 #     my $src_rs = $s->resultset('SrcVer')->
 190 #         search({-or => [-and => {'src_pkg.pkg' => [keys %src_packages],
 191 #                                  -or => {'suite.codename' => $common_dists,
 192 #                                          'suite.suite_name' => $common_dists,
 193 #                                         },
 194 #                                 },
 195 #                         @src_ver_search,
 196 #                        ],
 197 #                },
 198 #               {join => ['src_pkg',
 199 #                         {'src_associations' => 'suite'},
 200 #                        ],
 201 #                '+select' => [qw(src_pkg.pkg),
 202 #                              qw(suite.codename),
 203 #                              qw(src_associations.modified),
 204 #                              q(CONCAT(src_pkg.pkg,'/',me.ver))],
 205 #                '+as' => [qw(src_pkg_name codename modified_time src_pkg_ver)],
 206 #                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 207 #                order_by => {-desc => 'me.ver'}
 208 #               },
 209 #               );
 210 #     while (my $pkg = $src_rs->next) {
 211 #         my $n = 'src:'.$pkg->{src_pkg_name};
 212 #         if (exists $packages{$n}) {
 213 #             push @{$packages{$n}{versions}},
 214 #                 $pkg->{src_pkg_ver};
 215 #             if (defined $pkg->{codename}) {
 216 #                 push @{$packages{$n}{dists}{$pkg->{codename}}},
 217 #                     $#{$packages{$n}{versions}};
 218 #             }
 219 #         } else {
 220 #             $packages{$n} =
 221 #            {name => $pkg->{src_pkg_name},
 222 #             type => 'source',
 223 #             valid => 1,
 224 #             versions => [$pkg->{src_pkg_ver}],
 225 #             dists => {defined $pkg->{codename}?($pkg->{codename} => [1]):()},
 226 #            };
 227 #         }
 228 #     }
 229 #     return \%packages;
 230 # }
 231
 232 sub member_key {
 233     return $_[1]->qualified_name;
 234 }
 235
 236 has 'correspondent_collection' =>
 237     (is => 'ro',
 238      isa => 'Debbugs::Collection::Correspondent',
 239      default => sub {Debbugs::Collection::Correspondent->new()},
 240     );
 241
 242 has 'versiontree' =>
 243     (is => 'ro',
 244      isa => 'Debbugs::VersionTree',
 245      lazy => 1,
 246      builder => '_build_versiontree',
 247     );
 248
 249 sub _build_versiontree {
 250     my $self = shift;
 251     return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
 252 }
 253
 254
 255 sub get_source_versions_distributions {
 256     my $self = shift;
 257     my @return;
 258     push @return,
 259             $self->apply(sub {$_->get_source_version_distribution(@_)});
 260     return
 261         Debbugs::Collection::Version->new(versions => \@return,
 262                                           $self->has_schema?(schema => $self->schema):(),
 263                                           package_collection => $self->universe,
 264                                          );
 265 }
 266
 267 # given a list of binary versions or src/versions, returns all of the versions
 268 # in this package collection which are known to match. You'll have to be sure to
 269 # load appropriate versions beforehand for this to actually work.
 270 sub get_source_versions {
 271     my $self = shift;
 272     my @return;
 273     for my $ver (@_) {
 274         my $sv;
 275         if ($ver =~ m{(<src>.+?)/(?<ver>.+)$/}) {
 276             my $sp = $self->get_or_add_by_key('src:'.$+{src});
 277             push @return,
 278                 $sp->get_source_version($ver);
 279            next;
 280         } else {
 281             my $found_valid = 0;
 282             for my $p ($self->members) {
 283                 local $_;
 284                 my @vs =
 285                     grep {$_->is_valid}
 286                     $p->get_source_version($ver);
 287                 if (@vs) {
 288                     $found_valid = 1;
 289                     push @return,@vs;
 290                     next;
 291                 }
 292             }
 293             if (not $found_valid) {
 294                 push @return,
 295                     Debbugs::Version::Binary->new(version => $ver,
 296                                                   package_collection => $self->universe,
 297                                                   valid => 0,
 298                                                   $self->has_schema?(schema => $self->schema):(),
 299                                                  );
 300             }
 301         }
 302     }
 303     return
 304         Debbugs::Collection::Version->new(versions => \@return,
 305                                           $self->has_schema?(schema => $self->schema):(),
 306                                           package_collection => $self->universe,
 307                                          );
 308 }
 309
 310
 311 __PACKAGE__->meta->make_immutable;
 312
 313 1;
 314
 315 __END__
 316 # Local Variables:
 317 # indent-tabs-mode: nil
 318 # cperl-indent-level: 4
 319 # End: