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