Debbugs/Collection/Version.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::Version;
   8
   9 =head1 NAME
  10
  11 Debbugs::Collection::Version -- Version 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 use Debbugs::Common qw(make_list hash_slice);
  27 use Debbugs::Config qw(:config);
  28 use Debbugs::OOTypes;
  29 use Debbugs::Version;
  30
  31 use List::AllUtils qw(part);
  32
  33 extends 'Debbugs::Collection';
  34
  35 has '+members' => (isa => 'ArrayRef[Debbugs::Version]');
  36
  37 has 'package_collection' =>
  38     (is => 'ro',
  39      isa => 'Debbugs::Collection::Package',
  40      builder => '_build_package_collection',
  41      lazy => 1,
  42     );
  43
  44 sub _build_package_collection {
  45     my $self = shift;
  46     return Debbugs::Collection::Package->new($self->schema_argument);
  47 }
  48
  49 sub member_key {
  50     return $_[1]->package.'/'.$_[1]->version.'/'.$_[1]->arch;
  51 }
  52
  53
  54 around add_by_key => sub {
  55     my $orig = shift;
  56     my $self = shift;
  57     my @members =
  58         $self->_member_constructor(versions => [@_]);
  59     return $self->$orig(@members);
  60 };
  61
  62 sub _member_constructor {
  63     my $self = shift;
  64     my %args = @_;
  65     my @schema_arg;
  66     my @return;
  67     for my $pkg_ver_arch (make_list($args{versions})) {
  68         my ($pkg,$ver,$arch) = $pkg_ver_arch =~ m{^([^/]+)/([^/]+)/?([^/]*)$} or
  69             confess("Invalid version key: $pkg_ver_arch");
  70         if (not length $arch) {
  71             if ($pkg =~ /^src:/) {
  72                 $arch = 'source';
  73             } else {
  74                $arch = 'any';
  75             }
  76         }
  77         if ($arch eq 'source') {
  78             push @return,
  79                 Debbugs::Version::Source->
  80                     new($self->schema_argument,
  81                         package => $pkg,
  82                         version => $ver,
  83                        );
  84         } else {
  85             push @return,
  86                 Debbugs::Version::Binary->
  87                     new($self->schema_argument,
  88                         package => $pkg,
  89                         version => $ver,
  90                         arch => [$arch],
  91                        );
  92         }
  93     }
  94 }
  95
  96 # Debbugs::Collection::Versions do not have a universe.
  97 sub universe {
  98     return $_[0];
  99 }
 100
 101 sub source {
 102     my $self = shift;
 103     return $self->map(sub{$_->source});
 104 }
 105
 106 __PACKAGE__->meta->make_immutable;
 107
 108 1;
 109
 110 __END__
 111 # Local Variables:
 112 # indent-tabs-mode: nil
 113 # cperl-indent-level: 4
 114 # End: