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     use Data::Printer;
  51     p @_;
  52     return $_[1]->package.'/'.$_[1]->version.'/'.$_[1]->arch;
  53 }
  54
  55
  56 around add_by_key => sub {
  57     my $orig = shift;
  58     my $self = shift;
  59     my @members =
  60         $self->_member_constructor(versions => [@_]);
  61     return $self->$orig(@members);
  62 };
  63
  64 sub _member_constructor {
  65     my $self = shift;
  66     my %args = @_;
  67     my @schema_arg;
  68     my @return;
  69     for my $pkg_ver_arch (make_list($args{versions})) {
  70         my ($pkg,$ver,$arch) = $pkg_ver_arch =~ m{^([^/]+)/([^/]+)/?([^/]*)$} or
  71             confess("Invalid version key: $pkg_ver_arch");
  72         if (not length $arch) {
  73             if ($pkg =~ /^src:/) {
  74                 $arch = 'source';
  75             } else {
  76                $arch = 'any';
  77             }
  78         }
  79         if ($arch eq 'source') {
  80             push @return,
  81                 Debbugs::Version::Source->
  82                     new($self->schema_argument,
  83                         package => $pkg,
  84                         version => $ver,
  85                        );
  86         } else {
  87             push @return,
  88                 Debbugs::Version::Binary->
  89                     new($self->schema_argument,
  90                         package => $pkg,
  91                         version => $ver,
  92                         arch => [$arch],
  93                        );
  94         }
  95     }
  96 }
  97
  98 # Debbugs::Collection::Versions do not have a universe.
  99 sub universe {
 100     return $_[0];
 101 }
 102
 103 sub source {
 104     my $self = shift;
 105     return $self->map(sub{$_->source});
 106 }
 107
 108 __PACKAGE__->meta->make_immutable;
 109
 110 1;
 111
 112 __END__
 113 # Local Variables:
 114 # indent-tabs-mode: nil
 115 # cperl-indent-level: 4
 116 # End: