X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCollection%2FPackage.pm;fp=Debbugs%2FCollection%2FPackage.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=055cbaeb6e052b8047f5791596602a9b87ac6eda;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/Collection/Package.pm b/Debbugs/Collection/Package.pm deleted file mode 100644 index 055cbae..0000000 --- a/Debbugs/Collection/Package.pm +++ /dev/null @@ -1,293 +0,0 @@ -# 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 . - -package Debbugs::Collection::Package; - -=head1 NAME - -Debbugs::Collection::Package -- Package generation factory - -=head1 SYNOPSIS - -This collection extends L and contains members of -L. 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 - -=over - -=item correspondent_collection - -Optional L which is used to look up correspondents - - -=item versiontree - -Optional L which contains known package source versions - -=back - -=head1 Methods - -=head2 correspondent_collection - - $packages->correspondent_collection - -Returns the L for this package collection - -=head2 versiontree - -Returns the L 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 of all of the versions in this package -collection which are known to match. - -Effectively, this calls L 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 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. -For unqualified versions, calls L; 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{(?.+?)/(?.+)$}) { - 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 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 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: