1 # This module is part of debbugs, and
2 # is released under the terms of the GPL version 3, or any later
3 # version (at your option). See the file README and COPYING for more
5 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
7 package Debbugs::Package;
11 Debbugs::Package -- OO interface to packages
16 Debbugs::Package->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
26 use v5.10; # for state
27 use namespace::autoclean;
29 use List::AllUtils qw(uniq pairmap);
30 use Debbugs::Config qw(:config);
31 use Debbugs::Version::Source;
32 use Debbugs::Version::Binary;
34 extends 'Debbugs::OOBase';
42 name if binary, name prefixed with C<src:> if source
46 has name => (is => 'ro', isa => 'Str',
53 # src: if source, nothing if binary
54 ($self->_type eq 'source' ? 'src:':'') .
61 Type of the package; either C<binary> or C<source>
65 has type => (is => 'bare', isa => 'Str',
67 builder => '_build_type',
68 clearer => '_clear_type',
70 writer => '_set_type',
75 if ($self->name !~ /^src:/) {
88 return $config{web_domain}.'/'.$self->qualified_name;
91 around BUILDARGS => sub {
95 if (@_==1 and ref($_[0]) eq 'HASH') {
100 $args{name} //= '(unknown)';
101 if ($args{name} =~ /src:(.+)/) {
103 $args{type} = 'source';
105 $args{type} = 'binary' unless
108 return $class->$orig(%args);
113 true if the package is a source package
117 true if the package is a binary package
122 return $_[0]->_type eq 'source'
126 return $_[0]->_type eq 'binary'
129 =head2 valid -- true if the package has any valid versions
133 has valid => (is => 'ro', isa => 'Bool',
135 builder => '_build_valid',
136 writer => '_set_valid',
141 if ($self->valid_version_info_count> 0) {
147 # this contains source name, source version, binary name, binary version, arch,
148 # and dist which have been selected from the database. It is used to build
149 # versions and anything else which are known as required.
150 has 'valid_version_info' =>
151 (is => 'bare', isa => 'ArrayRef',
154 builder => '_build_valid_version_info',
155 predicate => '_has_valid_version_info',
156 clearer => '_clear_valid_version_info',
157 handles => {'_get_valid_version_info' => 'get',
158 'valid_version_info_grep' => 'grep',
159 '_valid_version_info' => 'elements',
160 'valid_version_info_count' => 'count',
164 sub _build_valid_version_info {
166 my $pkgs = $self->_get_valid_version_info_from_db;
167 for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) {
168 $self->_mark_invalid_version($invalid_version,1);
170 return $pkgs->{$self->qualified_name}->{valid_version_info} // [];
173 state $common_dists = [@{$config{distributions}}];
174 sub _get_valid_version_info_from_db {
176 if ((@_ % 2) == 1 and
184 if ($self->has_schema) {
189 @packages = $self->qualified_name;
192 @packages = @{$args{packages}};
194 if (not defined $s) {
195 confess("get_info_from_db not implemented without schema");
198 my %src_ver_packages;
200 my %bin_ver_packages;
201 # split packages into src/ver, bin/ver, src, and bin so we can select them
204 for my $pkg (@packages) {
206 if ($pkg->[0] =~ /^src:(.+)$/) {
207 for my $ver (@{$pkg}[1..$#{$pkg}]) {
208 $src_ver_packages{$1}{$ver} = 0;
211 for my $ver (@{$pkg}[1..$#{$pkg}]) {
212 $bin_ver_packages{$pkg->[0]}{$ver} = 0;
215 } elsif ($pkg =~ /^src:(.+)$/) {
216 $src_packages{$1} = 0;
218 $bin_packages{$pkg} = 0;
221 # calculate searches for packages where we want specific versions. We
222 # calculate this here so add_result_to_package can stomp over
223 # %src_ver_packages and %bin_ver_packages
225 for my $sp (keys %src_ver_packages) {
226 push @src_ver_search,
227 (-and => {'src_pkg.pkg' => $sp,
228 'me.ver' => [keys %{$src_ver_packages{$sp}}],
234 for my $sp (keys %bin_ver_packages) {
235 push @bin_ver_search,
236 (-and => {'bin_pkg.pkg' => $sp,
237 'me.ver' => [keys %{$bin_ver_packages{$sp}}],
242 sub _default_pkg_info {
243 return {name => $_[0],
244 type => $_[1]//'source',
246 valid_version_info => [],
247 invalid_versions => {},
250 sub add_result_to_package {
251 my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_;
252 while (my $pkg = $rs->next) {
253 my $n = 'src:'.$pkg->{src_pkg};
254 if (not exists $pkgs->{$n}) {
256 _default_pkg_info($pkg->{src_pkg});
258 push @{$pkgs->{$n}{valid_version_info}},
260 $n = $pkg->{bin_pkg};
261 if (not exists $pkgs->{$n}) {
263 _default_pkg_info($pkg->{bin_pkg},'binary');
265 push @{$pkgs->{$n}{valid_version_info}},
267 # this is a package with a valid src_ver
268 $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++;
269 $sp->{$pkg->{src_pkg}}++;
270 # this is a package with a valid bin_ver
271 $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++;
272 $bp->{$pkg->{bin_pkg}}++;
275 if (keys %src_packages) {
276 my $src_rs = $s->resultset('SrcVer')->
277 search({-or => [-and => {'src_pkg.pkg' => [keys %src_packages],
278 -or => {'suite.codename' => $common_dists,
279 'suite.suite_name' => $common_dists,
287 'src_associations' => 'suite'},
289 'bin_vers' => ['bin_pkg','arch']},
292 'select' => [qw(src_pkg.pkg),
294 qw(suite.suite_name),
295 qw(src_associations.modified),
297 q(CONCAT(src_pkg.pkg,'/',me.ver)),
298 qw(bin_vers.ver bin_pkg.pkg arch.arch),
301 'as' => [qw(src_pkg codename suite_name),
302 qw(modified_time src_ver src_pkg_ver),
303 qw(bin_ver bin_pkg arch maintainer),
305 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
308 add_result_to_package($packages,$src_rs,
315 if (keys %bin_packages) {
317 $s->resultset('BinAssociation')->
318 search({-and => {'bin_pkg.pkg' => [keys %bin_packages],
319 -or => {'suite.codename' => $common_dists,
320 'suite.suite_name' => $common_dists,
324 [{'src_ver' => ['src_pkg',
331 'select' => [qw(src_pkg.pkg),
333 qw(suite.suite_name),
336 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
337 qw(bin.ver bin_pkg.pkg arch.arch),
340 'as' => [qw(src_pkg codename suite_name),
341 qw(modified_time src_ver src_pkg_ver),
342 qw(bin_ver bin_pkg arch maintainer),
344 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
347 add_result_to_package($packages,$bin_assoc_rs,
354 if (@bin_ver_search) {
355 my $bin_rs = $s->resultset('BinVer')->
356 search({-or => [@bin_ver_search,
361 'bin_associations' => 'suite'},
362 {'src_ver' => ['src_pkg',
367 'select' => [qw(src_pkg.pkg),
369 qw(suite.suite_name),
370 qw(bin_associations.modified),
372 q(CONCAT(src_pkg.pkg,'/',src_ver.ver)),
373 qw(me.ver bin_pkg.pkg arch.arch),
376 'as' => [qw(src_pkg codename suite_name),
377 qw(modified_time src_ver src_pkg_ver),
378 qw(bin_ver bin_pkg arch maintainer),
380 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
383 add_result_to_package($packages,$bin_rs,
390 for my $sp (keys %src_ver_packages) {
391 if (not exists $packages->{'src:'.$sp}) {
392 $packages->{'src:'.$sp} =
393 _default_pkg_info($sp,'source',0);
395 for my $sv (keys %{$src_ver_packages{$sp}}) {
396 next if $src_ver_packages{$sp}{$sv} > 0;
397 $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1;
400 for my $bp (keys %bin_ver_packages) {
401 if (not exists $packages->{$bp}) {
403 _default_pkg_info($bp,'binary',0);
405 for my $bv (keys %{$bin_ver_packages{$bp}}) {
406 next if $bin_ver_packages{$bp}{$bv} > 0;
407 $packages->{$bp}{invalid_versions}{$bv} = 1;
410 for my $sp (keys %src_packages) {
411 next if $src_packages{$sp} > 0;
412 $packages->{'src:'.$sp} =
413 _default_pkg_info($sp,'source',0);
415 for my $bp (keys %bin_packages) {
416 next if $bin_packages{$bp} > 0;
418 _default_pkg_info($bp,'binary',0);
423 has 'source_version_to_info' =>
424 (is => 'bare', isa => 'HashRef',
427 builder => '_build_source_version_to_info',
428 handles => {_get_source_version_to_info => 'get',
432 sub _build_source_version_to_info {
436 for my $v ($self->_valid_version_info) {
437 push @{$info->{$v->{src_ver}}}, $i;
443 has 'binary_version_to_info' =>
444 (is => 'bare', isa => 'HashRef',
447 builder => '_build_binary_version_to_info',
448 handles => {_get_binary_version_to_info => 'get',
452 sub _build_binary_version_to_info {
456 for my $v ($self->_valid_version_info) {
457 push @{$info->{$v->{bin_ver}}}, $i;
463 has 'dist_to_info' =>
464 (is => 'bare', isa => 'HashRef',
467 builder => '_build_dist_to_info',
468 handles => {_get_dist_to_info => 'get',
471 sub _build_dist_to_info {
475 for my $v ($self->_valid_version_info) {
476 next unless defined $v->{suite_name} and length($v->{suite_name});
477 push @{$info->{$v->{suite_name}}}, $i;
483 # this is a hashref of versions that we know are invalid
484 has 'invalid_versions' =>
485 (is => 'bare',isa => 'HashRef[Bool]',
488 clearer => '_clear_invalid_versions',
490 handles => {_invalid_version => 'exists',
491 _mark_invalid_version => 'set',
495 has 'binaries' => (is => 'ro',
496 isa => 'Debbugs::Collection::Package',
498 builder => '_build_binaries',
499 predicate => '_has_binaries',
502 sub _build_binaries {
504 if ($self->is_binary) {
505 return $self->package_collection->limit($self->name);
507 # OK, walk through the valid_versions for this package
509 uniq map {$_->{bin_pkg}} $self->_valid_version_info;
510 return $self->package_collection->limit(@binaries);
513 has 'sources' => (is => 'ro',
514 isa => 'Debbugs::Collection::Package',
516 builder => '_build_sources',
517 predicate => '_has_sources',
522 return $self->package_collection->limit($self->source_names);
528 if ($self->is_source) {
531 return uniq map {'src:'.$_->{src_pkg}} $self->_valid_version_info;
536 L<Debbugs::Collection::Correspondent> of the maintainer(s) of the current package
540 has maintainers => (is => 'ro',
541 isa => 'Debbugs::Collection::Correspondent',
543 builder => '_build_maintainers',
544 predicate => '_has_maintainers',
547 sub _build_maintainers {
550 for my $v ($self->_valid_version_info) {
551 next unless length($v->{suite_name}) and length($v->{maintainer});
552 push @maintainers,$v->{maintainer};
556 return $self->correspondent_collection->limit(@maintainers);
559 has 'versions' => (is => 'bare',
560 isa => 'HashRef[Debbugs::Version]',
562 handles => {_exists_version => 'exists',
563 _get_version => 'get',
564 _set_version => 'set',
567 builder => '_build_versions',
570 sub _build_versions {
582 $self->_set_version(@set);
585 sub get_source_version_distribution {
588 my %src_pkg_vers = @_;
592 $self->_get_dist_to_info($dist);
594 _get_valid_version_info(@ver_loc)) {
595 $src_pkg_vers{$v->{src_pkg_ver}} = 1;
598 return $self->package_collection->
599 get_source_versions(keys %src_pkg_vers)->members;
602 # returns the source version(s) corresponding to the version of *this* package; the
603 # version passed may be binary or source, depending.
604 sub get_source_version {
606 if ($self->is_source) {
607 return $self->get_version(@_);
614 ($ver,@archs) = @{$ver};
615 @archs{@archs} = (1) x @archs;
618 @{$self->_get_binary_version_to_info($ver)//[]};
619 next unless @ver_loc;
620 my @vers = map {$self->
621 _get_valid_version_info($_)}
625 next unless exists $archs{$v->{arch}};
627 $src_pkg_vers{$v->{src_pkg_ver}} = 1;
630 return $self->package_collection->
631 get_source_versions(keys %src_pkg_vers)->members;
638 if ($self->_exists_version($v)) {
639 push @ret,$self->_get_version($v);
642 $self->_create_version($v);
648 sub _create_version {
651 if ($self->is_source) {
655 Debbugs::Version::Source->
656 new(package => $self,
658 package_collection => $self->package_collection,
659 $self->schema_argument,
666 Debbugs::Version::Binary->
667 new(package => $self,
669 package_collection => $self->package_collection,
670 $self->schema_argument,
674 $self->_set_version(@versions);
677 =head2 package_collection
679 L<Debbugs::Collection::Package> to get additional packages required
683 # gets used to retrieve packages
684 has 'package_collection' => (is => 'ro',
685 isa => 'Debbugs::Collection::Package',
686 builder => '_build_package_collection',
690 sub _build_package_collection {
692 return Debbugs::Collection::Package->new($self->schema_argument)
695 =head2 correspondent_collection
697 L<Debbugs::Collection::Correspondent> to get additional maintainers required
701 has 'correspondent_collection' => (is => 'ro',
702 isa => 'Debbugs::Collection::Correspondent',
703 builder => '_build_correspondent_collection',
707 sub _build_correspondent_collection {
709 return Debbugs::Collection::Correspondent->new($self->schema_argument)
714 return 'Debbugs::Package={package='.$self->qualified_name.'}';
717 __PACKAGE__->meta->make_immutable;
725 # indent-tabs-mode: nil
726 # cperl-indent-level: 4