Debbugs/Collection.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;
   8
   9 =head1 NAME
  10
  11 Debbugs::Collection -- Collection base class which can generate lots of objects
  12
  13 =head1 SYNOPSIS
  14
  15
  16 =head1 DESCRIPTION
  17
  18
  19
  20 =cut
  21
  22 use Mouse;
  23 use strictures 2;
  24 use namespace::autoclean;
  25 use List::AllUtils qw(pairmap);
  26
  27 extends 'Debbugs::OOBase';
  28
  29 has 'members' => (is => 'bare',
  30                   isa => 'ArrayRef',
  31                   traits => ['Array'],
  32                   default => sub {[]},
  33                   writer => '_set_members',
  34                   predicate => '_has_members',
  35                   handles => {_add => 'push',
  36                               members => 'elements',
  37                               count => 'count',
  38                               _get_member => 'get',
  39                               grep => 'grep',
  40                               apply => 'apply',
  41                               map => 'map',
  42                               sort => 'sort',
  43                              },
  44                  );
  45
  46 sub members_ref {
  47     my $self = shift;
  48     return [$self->members];
  49 }
  50
  51 has 'member_hash' => (traits => ['Hash'],
  52                       is => 'bare',
  53                       # really a HashRef[Int], but type checking is too slow
  54                       isa => 'HashRef',
  55                       lazy => 1,
  56                       reader => '_member_hash',
  57                       builder => '_build_member_hash',
  58                       clearer => '_clear_member_hash',
  59                       predicate => '_has_member_hash',
  60                       writer => '_set_member_hash',
  61                       handles => {# _add_member_hash => 'set',
  62                                   _member_key_exists => 'exists',
  63                                   _get_member_hash => 'get',
  64                                  },
  65                      );
  66
  67 # because _add_member_hash needs to be fast, we are overriding the default set
  68 # method which is very safe but slow, because it makes copies.
  69 sub _add_member_hash {
  70     my ($self,@kv) = @_;
  71     pairmap {
  72         defined($a)
  73             or $self->meta->
  74             throw_error("Hash keys passed to _add_member_hash must be defined" );
  75         ($b eq int($b)) or
  76             $self->meta->
  77             throw_error("Values passed to _add_member_hash must be integer");
  78     } @kv;
  79     my @return;
  80     while (my ($key, $value) = splice @kv, 0, 2 ) {
  81         push @return,
  82             $self->{member_hash}{$key} = $value
  83     }
  84     wantarray ? return @return: return $return[0];
  85 }
  86
  87 has 'universe' => (is => 'ro',
  88                    isa => 'Debbugs::Collection',
  89                    required => 1,
  90                    builder => '_build_universe',
  91                    writer => '_set_universe',
  92                    predicate => 'has_universe',
  93                   );
  94
  95 sub _build_universe {
  96     # By default, the universe is myself
  97     return $_[0];
  98 }
  99
 100 sub clone {
 101     my $self = shift;
 102     my $new = bless { %{$self} }, ref $self;
 103     if ($self->_has_members) {
 104         $new->_set_members([$self->members]);
 105     }
 106     if ($self->_has_member_hash) {
 107         $new->_set_member_hash({%{$self->_member_hash}})
 108     }
 109     return $new;
 110 }
 111
 112 sub _shallow_clone {
 113     my $self = shift;
 114     return bless { %{$self} }, ref $self;
 115 }
 116
 117 sub limit {
 118     my $self = shift;
 119     my $limit = $self->_shallow_clone();
 120     # Set the universe to whatever my universe is (potentially myself)
 121     # $limit->_set_universe($self->universe);
 122     $limit->_set_members([]);
 123     $limit->_clear_member_hash();
 124     $limit->add($self->universe->get_or_create(@_)) if @_;
 125     return $limit;
 126 }
 127
 128 sub get_or_create {
 129     my $self = shift;
 130     return () unless @_;
 131     my @return;
 132     my @exists;
 133     my @need_to_add;
 134     for my $i (0..$#_) {
 135         # we assume that if it's already a blessed reference, that it's the right
 136         if (blessed($_[$i])) {
 137             $return[$i] =
 138                 $_[$i];
 139         }
 140         elsif ($self->_member_key_exists($_[$i])) {
 141             push @exists,$i;
 142         } else {
 143             push @need_to_add,$i;
 144         }
 145     }
 146     # create and add by key
 147     if (@need_to_add) {
 148         @return[@need_to_add] =
 149             $self->add_by_key(@_[@need_to_add]);
 150     }
 151     if (@exists) {
 152         @return[@exists] =
 153             $self->get(@_[@exists]);
 154     }
 155     # if we've only been asked to get or create one thing, then it's expected
 156     # that we are returning only one thing
 157     if (@_ == 1) {
 158         return $return[0];
 159     }
 160     return @return;
 161 }
 162
 163 has 'constructor_args' => (is => 'rw',
 164                            isa => 'ArrayRef',
 165                            lazy => 1,
 166                            builder => '_build_constructor_args',
 167                           );
 168
 169 sub _build_constructor_args {
 170     return [];
 171 }
 172
 173 sub add_by_key {
 174     my $self = shift;
 175     # we'll assume that add does the right thing. around this in subclasses
 176     return $self->add(@_);
 177 }
 178
 179 sub add {
 180     my $self = shift;
 181     my @members_added;
 182     for my $member (@_) {
 183         if (not defined $member) {
 184             confess("Undefined member to add");
 185         }
 186         push @members_added,$member;
 187         if ($self->exists($member)) {
 188             next;
 189         }
 190         $self->_add($member);
 191         $self->_add_member_hash($self->member_key($member),
 192                                 $self->count()-1,
 193                                );
 194     }
 195     return @members_added;
 196 }
 197
 198 sub get {
 199     my $self = shift;
 200     return $self->_get_member($self->_get_member_hash(@_));
 201 }
 202
 203
 204 sub member_key {
 205     return $_[1];
 206 }
 207
 208 sub exists {
 209     my $self = shift;
 210     return $self->_member_key_exists($self->member_key($_[0]));
 211 }
 212
 213 sub _build_member_hash {
 214     my $self = shift;
 215     my $hash = {};
 216     my $i = 0;
 217     for my $member ($self->members) {
 218         $hash->{$self->member_key($member)} =
 219             $i++;
 220     }
 221     return $hash;
 222 }
 223
 224 sub CARP_TRACE {
 225     my $self = shift;
 226     return 'Debbugs::Collection={n_members='.$self->count().'}';
 227 }
 228
 229
 230 __PACKAGE__->meta->make_immutable;
 231 no Mouse;
 232 1;
 233
 234 __END__
 235 # Local Variables:
 236 # indent-tabs-mode: nil
 237 # cperl-indent-level: 4
 238 # End: