+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Collection::Package;
-
-=head1 NAME
-
-Debbugs::Collection::Package -- Package generation factory
-
-=head1 SYNOPSIS
-
-This collection extends L<Debbugs::Collection> and contains members of
-L<Debbugs::Package>. Useful for any field which contains one or more package or
-tracking lists of packages
-
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use v5.10; # for state
-use namespace::autoclean;
-
-use Carp;
-use Debbugs::Common qw(make_list hash_slice);
-use Debbugs::Config qw(:config);
-use Debbugs::OOTypes;
-use Debbugs::Package;
-
-use List::AllUtils qw(part);
-
-use Debbugs::Version::Binary;
-use Debbugs::Collection::Version;
-use Debbugs::Collection::Correspondent;
-use Debbugs::VersionTree;
-
-extends 'Debbugs::Collection';
-
-=head1 Object Creation
-
-=head2 my $packages = Debbugs::Collection::Package->new(%params|$param)
-
-Parameters in addition to those defined by L<Debbugs::Collection>
-
-=over
-
-=item correspondent_collection
-
-Optional L<Debbugs::Collection::Correspondent> which is used to look up correspondents
-
-
-=item versiontree
-
-Optional L<Debbugs::VersionTree> which contains known package source versions
-
-=back
-
-=head1 Methods
-
-=head2 correspondent_collection
-
- $packages->correspondent_collection
-
-Returns the L<Debbugs::Collection::Correspondent> for this package collection
-
-=head2 versiontree
-
-Returns the L<Debbugs::VersionTree> for this package collection
-
-=cut
-
-has '+members' => (isa => 'ArrayRef[Debbugs::Package]');
-
-sub BUILD {
- my $self = shift;
- my $args = shift;
- if (exists $args->{packages}) {
- $self->
- add($self->_member_constructor(packages =>
- $args->{packages}));
- }
-}
-
-around add_by_key => sub {
- my $orig = shift;
- my $self = shift;
- my @members =
- $self->_member_constructor(packages => [@_]);
- return $self->$orig(@members);
-};
-
-sub _member_constructor {
- # handle being called $self->_member_constructor;
- my $self = shift;
- my %args = @_;
- my $schema;
- if ($self->has_schema) {
- $schema = $self->schema;
- }
- my @return;
- if (defined $schema) {
- if (not ref($args{packages}) or @{$args{packages}} == 1 and
- $self->universe->count() > 0
- ) {
- carp("Likely inefficiency; member_constructor called with one argument");
- }
- my $packages =
- Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages},
- schema => $schema,
- );
- for my $package (keys %{$packages}) {
- push @return,
- Debbugs::Package->new(%{$packages->{$package}},
- schema => $schema,
- package_collection => $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- );
- }
- } else {
- for my $package (make_list($args{packages})) {
- push @return,
- Debbugs::Package->new(name => $package,
- package_collection => $self->universe,
- correspondent_collection =>
- $self->correspondent_collection->universe,
- );
- }
- }
- return @return;
-}
-
-sub add_packages_and_versions {
- my $self = shift;
- $self->add($self->_member_constructor(packages => \@_));
-}
-
-
-sub member_key {
- return $_[1]->qualified_name;
-}
-
-has 'correspondent_collection' =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Correspondent',
- default => sub {Debbugs::Collection::Correspondent->new()},
- );
-
-has 'versiontree' =>
- (is => 'ro',
- isa => 'Debbugs::VersionTree',
- lazy => 1,
- builder => '_build_versiontree',
- );
-
-sub _build_versiontree {
- my $self = shift;
- return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):());
-}
-
-=head2 get_source_versions_distributions
-
- $packages->get_source_versions_distributions('unstable')
-
-Given a list of distributions or suites, returns a
-L<Debbugs::Collection::Version> of all of the versions in this package
-collection which are known to match.
-
-Effectively, this calls L<Debbugs::Package/get_source_version_distribution> for
-each package in the collection and merges the results and returns them
-
-=cut
-
-sub get_source_versions_distributions {
- my $self = shift;
- my @return;
- push @return,
- $self->map(sub {$_->get_source_version_distribution(@_)});
- if (@return > 1) {
- return $return[0]->combine($return[1..$#return]);
- }
- return @return;
-}
-
-
-=head2 get_source_versions
-
- $packages->get_source_versions('1.2.3-1','foo/1.2.3-5')
-
-Given a list of binary versions or src/versions, returns a
-L<Debbugs::Collection::Version> of all of the versions in this package
-collection which are known to match.
-
-If you give a binary version ('1.2.3-1'), you must have already loaded source
-packages into this package collection for it to find an appropriate match.
-
-If no package is known to match, an version which is invalid will be returned
-
-For fully qualified versions this loads the appropriate source package into the
-universe of this collection and calls L<Debbugs::Package/get_source_version>.
-For unqualified versions, calls L<Debbugs::Package/get_source_version>; if no
-valid versions are returned, creates an invalid version.
-
-=cut
-
-sub get_source_versions {
- my $self = shift;
- my @return;
- for my $ver (@_) {
- my $sv;
- if ($ver =~ m{(?<src>.+?)/(?<ver>.+)$}) {
- my $sp = $self->universe->
- get_or_add_by_key('src:'.$+{src});
- push @return,
- $sp->get_source_version($+{ver});
- next;
- } else {
- my $found_valid = 0;
- for my $p ($self->members) {
- local $_;
- my @vs =
- grep {$_->is_valid}
- $p->get_source_version($ver);
- if (@vs) {
- $found_valid = 1;
- push @return,@vs;
- next;
- }
- }
- if (not $found_valid) {
- push @return,
- Debbugs::Version::Binary->new(version => $ver,
- package_collection => $self->universe,
- valid => 0,
- $self->schema_argument,
- );
- }
- }
- }
- return
- Debbugs::Collection::Version->new(members => \@return,
- $self->schema_argument,
- package_collection => $self->universe,
- );
-}
-
-=head2 source_names
-
- $packages->source_names()
-
-Returns a unique list of source names from all members of this collection by
-calling L<Debbugs::Package/source_names> on each member.
-
-=cut
-
-sub source_names {
- my $self = shift;
- local $_;
- return uniq map {$_->source_names} $self->members;
-}
-
-=head2 sources
-
- $packages->sources()
-
-Returns a L<Debbugs::Collection::Package> limited to source packages
-corresponding to all packages in this collection
-
-=cut
-
-sub sources {
- my $self = shift;
- return $self->universe->limit($self->source_names);
-}
-
-
-__PACKAGE__->meta->make_immutable;
-no Mouse;
-
-1;
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
projects / debbugs.git / blobdiff