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 This base class is designed for holding collections of objects which can be
  16 uniquely identified by a key and added/generated by that same key.
  17
  18 =head1 DESCRIPTION
  19
  20
  21
  22 =cut
  23
  24 use Mouse;
  25 use strictures 2;
  26 use namespace::autoclean;
  27 use List::AllUtils qw(pairmap);
  28 use Carp qw(croak);
  29
  30 extends 'Debbugs::OOBase';
  31
  32 =head1 METHODS
  33
  34 =head2 Debbugs::Collection->new(%params|$params)
  35
  36 Creates a new Debbugs::Collection object.
  37
  38 Parameters:
  39
  40 =over
  41
  42 =item universe
  43
  44 To avoid unnecessarily constructing new members, collections have a universe to
  45 which existing members can be obtained from. By default the universe is this
  46 collection. Generally, you should create exactly one universe for each
  47 collection type.
  48
  49 =item schema
  50
  51 Optional Debbugs::Schema object
  52
  53
  54 =back
  55
  56 =head2 $collection->members()
  57
  58 Returns list of members of this collection
  59
  60 =head2 $collection->members_ref()
  61
  62 Returns an ARRAYREF of members of this collection
  63
  64 =head2 $collection->keys_of_members()
  65
  66 Returns a list of the keys of all members of this collection
  67
  68 =head2 $collection->member_key($member)
  69
  70 Given a member, returns the key of that member
  71
  72 =head2 $collection->exists($member_key)
  73
  74 Returns true if a member with $member_key exists in the collection
  75
  76 =head2 $collection->clone()
  77
  78 Returns a clone of this collection with the same universe as this collection
  79
  80 =head2 $collection->limit(@member_keys)
  81
  82 Returns a new collection limited to the list of member keys passed
  83
  84 =head2 $collection->add($member)
  85
  86 Add a member to this collection
  87
  88 =head2 $collection->add_by_key($member_key)
  89
  90 Add a member to this collection by key
  91
  92 =head2 $collection->get($member_key)
  93
  94 Get member(s) by key, returning undef for keys which do not exist in the
  95 collection
  96
  97 =head2 $collection->get_or_add_by_key($member_key)
  98
  99 Get or add a member by the member key.
 100
 101 =head2 $collection->count()
 102
 103 Return the number of members in this collection
 104
 105 =head2 $collection->grep({$_ eq 5})
 106
 107 Return the members in this collection which satisfy the condition, setting $_
 108 locally to each member object
 109
 110 =head2 $collection->join(', ')
 111
 112 Returns the keys of the members of this collection joined
 113
 114 =head2 $collection->apply({$_*2}) $collection->map({$_*2})
 115
 116 Return the list of applying BLOCK to each member
 117
 118 =head2 $collection->sort({$a <=> $b})
 119
 120 Return the list of members sorted by BLOCK
 121
 122 =cut
 123
 124 has 'members' => (is => 'bare',
 125                   isa => 'ArrayRef',
 126                   traits => ['Array'],
 127                   default => sub {[]},
 128                   writer => '_set_members',
 129                   predicate => '_has_members',
 130                   handles => {_add => 'push',
 131                               members => 'elements',
 132                               count => 'count',
 133                               _get_member => 'get',
 134                               grep => 'grep',
 135                               apply => 'apply',
 136                               map => 'map',
 137                               sort => 'sort',
 138                              },
 139                  );
 140
 141 sub members_ref {
 142     my $self = shift;
 143     return [$self->members];
 144 }
 145
 146 has 'member_hash' => (traits => ['Hash'],
 147                       is => 'bare',
 148                       # really a HashRef[Int], but type checking is too slow
 149                       isa => 'HashRef',
 150                       lazy => 1,
 151                       reader => '_member_hash',
 152                       builder => '_build_member_hash',
 153                       clearer => '_clear_member_hash',
 154                       predicate => '_has_member_hash',
 155                       writer => '_set_member_hash',
 156                       handles => {# _add_member_hash => 'set',
 157                                   _member_key_exists => 'exists',
 158                                   _get_member_hash => 'get',
 159                                  },
 160                      );
 161
 162 # because _add_member_hash needs to be fast, we are overriding the default set
 163 # method which is very safe but slow, because it makes copies.
 164 sub _add_member_hash {
 165     my ($self,@kv) = @_;
 166     pairmap {
 167         defined($a)
 168             or $self->meta->
 169             throw_error("Hash keys passed to _add_member_hash must be defined" );
 170         ($b eq int($b)) or
 171             $self->meta->
 172             throw_error("Values passed to _add_member_hash must be integer");
 173     } @kv;
 174     my @return;
 175     while (my ($key, $value) = splice @kv, 0, 2 ) {
 176         push @return,
 177             $self->{member_hash}{$key} = $value
 178     }
 179     wantarray ? return @return: return $return[0];
 180 }
 181
 182 =head2 $collection->universe
 183
 184
 185 =cut
 186
 187 has 'universe' => (is => 'ro',
 188                    isa => 'Debbugs::Collection',
 189                    required => 1,
 190                    builder => '_build_universe',
 191                    writer => '_set_universe',
 192                    predicate => 'has_universe',
 193                   );
 194
 195 sub _build_universe {
 196     # By default, the universe is myself
 197     return $_[0];
 198 }
 199
 200 sub clone {
 201     my $self = shift;
 202     my $new = bless { %{$self} }, ref $self;
 203     if ($self->_has_members) {
 204         $new->_set_members([$self->members]);
 205     }
 206     if ($self->_has_member_hash) {
 207         $new->_set_member_hash({%{$self->_member_hash}})
 208     }
 209     return $new;
 210 }
 211
 212 sub _shallow_clone {
 213     my $self = shift;
 214     return bless { %{$self} }, ref $self;
 215 }
 216
 217 sub limit {
 218     my $self = shift;
 219     my $limit = $self->_shallow_clone();
 220     # Set the universe to whatever my universe is (potentially myself)
 221     # $limit->_set_universe($self->universe);
 222     $limit->_set_members([]);
 223     $limit->_clear_member_hash();
 224     $limit->add($self->universe->get_or_add_by_key(@_)) if @_;
 225     return $limit;
 226 }
 227
 228 sub get_or_add_by_key {
 229     my $self = shift;
 230     return () unless @_;
 231     my @return;
 232     my @exists;
 233     my @need_to_add;
 234     for my $i (0..$#_) {
 235         # we assume that if it's already a blessed reference, that it's the
 236         # right object to return
 237         if (ref $_[$i]) {
 238             croak "Passed a reference instead of a key to get_or_add_by_key";
 239         }
 240         elsif ($self->_member_key_exists($_[$i])) {
 241             push @exists,$i;
 242         } else {
 243             push @need_to_add,$i;
 244         }
 245     }
 246     # create and add by key
 247     if (@need_to_add) {
 248         @return[@need_to_add] =
 249             $self->add_by_key(@_[@need_to_add]);
 250     }
 251     if (@exists) {
 252         @return[@exists] =
 253             $self->get(@_[@exists]);
 254     }
 255     # if we've only been asked to get or create one thing, then it's expected
 256     # that we are returning only one thing
 257     if (@_ == 1) {
 258         return $return[0];
 259     }
 260     return @return;
 261 }
 262
 263 has 'constructor_args' => (is => 'rw',
 264                            isa => 'ArrayRef',
 265                            lazy => 1,
 266                            builder => '_build_constructor_args',
 267                           );
 268
 269 sub _build_constructor_args {
 270     return [];
 271 }
 272
 273 sub add_by_key {
 274     my $self = shift;
 275     # we'll assume that add does the right thing. around this in subclasses
 276     return $self->add(@_);
 277 }
 278
 279 sub add {
 280     my $self = shift;
 281     my @members_added;
 282     for my $member (@_) {
 283         if (not defined $member) {
 284             confess("Undefined member to add");
 285         }
 286         push @members_added,$member;
 287         if ($self->exists($member)) {
 288             next;
 289         }
 290         $self->_add($member);
 291         $self->_add_member_hash($self->member_key($member),
 292                                 $self->count()-1,
 293                                );
 294     }
 295     return @members_added;
 296 }
 297
 298 sub get {
 299     my $self = shift;
 300     my @res = map {$self->_get_member($_)}
 301         $self->_get_member_hash(@_);
 302     wantarray?@res:$res[0];
 303 }
 304
 305
 306 sub member_key {
 307     return $_[1];
 308 }
 309
 310 sub keys_of_members {
 311     my $self = shift;
 312     return $self->map(sub {$self->member_key($_[0])});
 313 }
 314
 315 sub exists {
 316     my $self = shift;
 317     return $self->_member_key_exists($self->member_key($_[0]));
 318 }
 319
 320 sub join {
 321     my $self = shift;
 322     my $joiner = shift;
 323     return CORE::join($joiner,$self->keys_of_members);
 324 }
 325
 326 sub _build_member_hash {
 327     my $self = shift;
 328     my $hash = {};
 329     my $i = 0;
 330     for my $member ($self->members) {
 331         $hash->{$self->member_key($member)} =
 332             $i++;
 333     }
 334     return $hash;
 335 }
 336
 337 sub CARP_TRACE {
 338     my $self = shift;
 339     my @members = $self->members;
 340     if (@members > 5) {
 341         @members = map {$self->member_key($_)}
 342             @members[0..4];
 343         push @members,'...';
 344     } else {
 345         @members = map {$self->member_key($_)} @members;
 346     }
 347     return __PACKAGE__.'={n_members='.$self->count().
 348         ',members=('.CORE::join(',',@members).')}';
 349 }
 350
 351
 352 __PACKAGE__->meta->make_immutable;
 353 no Mouse;
 354 1;
 355
 356 __END__
 357 # Local Variables:
 358 # indent-tabs-mode: nil
 359 # cperl-indent-level: 4
 360 # End: