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
  16 =head1 DESCRIPTION
  17
  18
  19
  20 =cut
  21
  22 use Mouse;
  23 use strictures 2;
  24 use v5.10; # for state
  25 use namespace::autoclean;
  26
  27 use Carp;
  28 use Debbugs::Common qw(make_list hash_slice);
  29 use Debbugs::Config qw(:config);
  30 use Debbugs::OOTypes;
  31 use Debbugs::Package;
  32
  33 use List::AllUtils qw(part);
  34
  35 use Debbugs::Version::Binary;
  36 use Debbugs::Collection::Version;
  37 use Debbugs::Collection::Correspondent;
  38 use Debbugs::VersionTree;
  39
  40 extends 'Debbugs::Collection';
  41
  42 has '+members' => (isa => 'ArrayRef[Debbugs::Package]');
  43
  44 sub BUILD {
  45     my $self = shift;
  46     my $args = shift;
  47     if (exists $args->{packages}) {
  48         $self->
  49             add($self->_member_constructor(packages =>
  50                                            $args->{packages}));
  51     }
  52 }
  53
  54 around add_by_key => sub {
  55     my $orig = shift;
  56     my $self = shift;
  57     my @members =
  58         $self->_member_constructor(packages => [@_]);
  59     return $self->$orig(@members);
  60 };
  61
  62 sub _member_constructor {
  63     # handle being called $self->_member_constructor;
  64     my $self = shift;
  65     my %args = @_;
  66     my $schema;
  67     if ($self->has_schema) {
  68         $schema = $self->schema;
  69     }
  70     my @return;
  71     if (defined $schema) {
  72         if (not ref($args{packages}) or @{$args{packages}} == 1) {
  73             carp("Likely inefficiency; member_constructor called with one argument");
  74         }
  75         my $packages =
  76             Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages},
  77                                                               schema => $schema,
  78                                                              );
  79         for my $package (keys %{$packages}) {
  80             push @return,
  81                 Debbugs::Package->new(%{$packages->{$package}},
  82                                       schema => $schema,
  83                                       package_collection => $self->universe,
  84                                       correspondent_collection =>
  85                                       $self->correspondent_collection->universe,
  86                                      );
  87         }
  88     } else {
  89         carp "No schema\n";
  90         for my $package (make_list($args{packages})) {
  91             push @return,
  92                 Debbugs::Package->new(name => $package,
  93                                       package_collection => $self->universe,
  94                                       correspondent_collection =>
  95                                       $self->correspondent_collection->universe,
  96                                      );
  97         }
  98     }
  99     return @return;
 100 }
 101
 102 sub add_packages_and_versions {
 103     my $self = shift;
 104     $self->add($self->_member_constructor(packages => \@_));
 105 }
 106
 107 # state $common_dists = [@{$config{distributions}}];
 108 # sub _get_packages {
 109 #     my %args = @_;
 110 #     my $s = $args{schema};
 111 #     my %src_packages;
 112 #     my %src_ver_packages;
 113 #     my %bin_packages;
 114 #     my %bin_ver_packages;
 115 #     # split packages into src/ver, bin/ver, src, and bin so we can select them
 116 #     # from the database
 117 #     local $_;
 118 #     for my $pkg (@{$args{packages}}) {
 119 #         if (ref($pkg)) {
 120 #             if ($pkg->[0] =~ /^src:(.+)$/) {
 121 #                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 122 #                     $src_ver_packages{$1}{$ver} = 1;
 123 #                 }
 124 #             } else {
 125 #                 for my $ver (@{$pkg}[1..$#{$pkg}]) {
 126 #                     $bin_ver_packages{$pkg->[0]}{$ver} = 1;
 127 #                 }
 128 #             }
 129 #         } elsif ($pkg =~ /^src:(.+)$/) {
 130 #             $src_packages{$1} = 1;
 131 #         } else {
 132 #             $bin_packages{$pkg} = 1;
 133 #         }
 134 #     }
 135 #     my @src_ver_search;
 136 #     for my $sp (keys %src_ver_packages) {
 137 #         push @src_ver_search,
 138 #             (-and => {'src_pkg.pkg' => $sp,
 139 #                       'me.ver' => [keys %{$src_ver_packages{$sp}}],
 140 #                      },
 141 #              );
 142 #     }
 143 #     my %packages;
 144 #     my $src_rs = $s->resultset('SrcVer')->
 145 #         search({-or => [-and => {'src_pkg.pkg' => [keys %src_packages],
 146 #                                  -or => {'suite.codename' => $common_dists,
 147 #                                          'suite.suite_name' => $common_dists,
 148 #                                         },
 149 #                                 },
 150 #                         @src_ver_search,
 151 #                        ],
 152 #                },
 153 #               {join => ['src_pkg',
 154 #                         {'src_associations' => 'suite'},
 155 #                        ],
 156 #                '+select' => [qw(src_pkg.pkg),
 157 #                              qw(suite.codename),
 158 #                              qw(src_associations.modified),
 159 #                              q(CONCAT(src_pkg.pkg,'/',me.ver))],
 160 #                '+as' => [qw(src_pkg_name codename modified_time src_pkg_ver)],
 161 #                result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 162 #                order_by => {-desc => 'me.ver'}
 163 #               },
 164 #               );
 165 #     while (my $pkg = $src_rs->next) {
 166 #         my $n = 'src:'.$pkg->{src_pkg_name};
 167 #         if (exists $packages{$n}) {
 168 #             push @{$packages{$n}{versions}},
 169 #                 $pkg->{src_pkg_ver};
 170 #             if (defined $pkg->{codename}) {
 171 #                 push @{$packages{$n}{dists}{$pkg->{codename}}},
 172 #                     $#{$packages{$n}{versions}};
 173 #             }
 174 #         } else {
 175 #             $packages{$n} =
 176 #            {name => $pkg->{src_pkg_name},
 177 #             type => 'source',
 178 #             valid => 1,
 179 #             versions => [$pkg->{src_pkg_ver}],
 180 #             dists => {defined $pkg->{codename}?($pkg->{codename} => [1]):()},
 181 #            };
 182 #         }
 183 #     }
 184 #     return \%packages;
 185 # }
 186
 187 sub member_key {
 188     return $_[1]->qualified_name;
 189 }
 190
 191 has 'correspondent_collection' =>
 192     (is => 'ro',
 193      isa => 'Debbugs::Collection::Correspondent',
 194      default => sub {Debbugs::Collection::Correspondent->new()},
 195     );
 196
 197 has 'versiontree' =>
 198     (is => 'ro',
 199      isa => 'Debbugs::VersionTree',
 200      lazy => 1,
 201      builder => '_build_versiontree',
 202     );
 203
 204 sub _build_versiontree {
 205     my $self = shift;
 206     return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
 207 }
 208
 209
 210 sub get_source_versions_distributions {
 211     my $self = shift;
 212     my @return;
 213     push @return,
 214             $self->apply(sub {$_->get_source_version_distribution(@_)});
 215     return
 216         Debbugs::Collection::Version->new(versions => \@return,
 217                                           $self->has_schema?(schema => $self->schema):(),
 218                                           package_collection => $self->universe,
 219                                          );
 220 }
 221
 222 # given a list of binary versions or src/versions, returns all of the versions
 223 # in this package collection which are known to match. You'll have to be sure to
 224 # load appropriate versions beforehand for this to actually work.
 225 sub get_source_versions {
 226     my $self = shift;
 227     my @return;
 228     for my $ver (@_) {
 229         my $sv;
 230         if ($ver =~ m{(<src>.+?)/(?<ver>.+)$/}) {
 231             my $sp = $self->get_or_create('src:'.$+{src});
 232             push @return,
 233                 $sp->get_source_version($ver);
 234            next;
 235         } else {
 236             my $found_valid = 0;
 237             for my $p ($self->members) {
 238                 local $_;
 239                 my @vs =
 240                     grep {$_->is_valid}
 241                     $p->get_source_version($ver);
 242                 if (@vs) {
 243                     $found_valid = 1;
 244                     push @return,@vs;
 245                     next;
 246                 }
 247             }
 248             if (not $found_valid) {
 249                 push @return,
 250                     Debbugs::Version::Binary->new(version => $ver,
 251                                                   package_collection => $self->universe,
 252                                                   valid => 0,
 253                                                   $self->has_schema?(schema => $self->schema):(),
 254                                                  );
 255             }
 256         }
 257     }
 258     return
 259         Debbugs::Collection::Version->new(versions => \@return,
 260                                           $self->has_schema?(schema => $self->schema):(),
 261                                           package_collection => $self->universe,
 262                                          );
 263 }
 264
 265
 266 __PACKAGE__->meta->make_immutable;
 267
 268 1;
 269
 270 __END__
 271 # Local Variables:
 272 # indent-tabs-mode: nil
 273 # cperl-indent-level: 4
 274 # End: