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. Will add new
  83 members to the universe if they do not currently exist.
  84
  85 =head2 $collection->add($member)
  86
  87 Add a member to this collection
  88
  89 =head2 $collection->add_by_key($member_key)
  90
  91 Add a member to this collection by key
  92
  93 =head2 $collection->combine($collection2) or $collection + $collection2
  94
  95 Combines the members of both collections together and returns the new collection
  96
  97 =head2 $collection->get($member_key)
  98
  99 Get member(s) by key, returning undef for keys which do not exist in the
 100 collection
 101
 102 =head2 $collection->get_or_add_by_key($member_key)
 103
 104 Get or add a member by the member key.
 105
 106 =head2 $collection->count()
 107
 108 Return the number of members in this collection
 109
 110 =head2 $collection->grep({$_ eq 5})
 111
 112 Return the members in this collection which satisfy the condition, setting $_
 113 locally to each member object
 114
 115 =head2 $collection->join(', ')
 116
 117 Returns the keys of the members of this collection joined
 118
 119 =head2 $collection->apply({$_*2}) $collection->map({$_*2})
 120
 121 Return the list of applying BLOCK to each member
 122
 123 =head2 $collection->sort({$a <=> $b})
 124
 125 Return the list of members sorted by BLOCK
 126
 127 =cut
 128
 129 has 'members' => (is => 'bare',
 130                   isa => 'ArrayRef',
 131                   traits => ['Array'],
 132                   default => sub {[]},
 133                   writer => '_set_members',
 134                   predicate => '_has_members',
 135                   handles => {_add => 'push',
 136                               members => 'elements',
 137                               count => 'count',
 138                               _get_member => 'get',
 139                               grep => 'grep',
 140                               apply => 'apply',
 141                               map => 'map',
 142                               sort => 'sort',
 143                              },
 144                  );
 145
 146 sub members_ref {
 147     my $self = shift;
 148     return [$self->members];
 149 }
 150
 151 has 'member_hash' => (traits => ['Hash'],
 152                       is => 'bare',
 153                       # really a HashRef[Int], but type checking is too slow
 154                       isa => 'HashRef',
 155                       lazy => 1,
 156                       reader => '_member_hash',
 157                       builder => '_build_member_hash',
 158                       clearer => '_clear_member_hash',
 159                       predicate => '_has_member_hash',
 160                       writer => '_set_member_hash',
 161                       handles => {# _add_member_hash => 'set',
 162                                   _member_key_exists => 'exists',
 163                                   _get_member_hash => 'get',
 164                                  },
 165                      );
 166
 167 # because _add_member_hash needs to be fast, we are overriding the default set
 168 # method which is very safe but slow, because it makes copies.
 169 sub _add_member_hash {
 170     my ($self,@kv) = @_;
 171     pairmap {
 172         defined($a)
 173             or $self->meta->
 174             throw_error("Hash keys passed to _add_member_hash must be defined" );
 175         ($b eq int($b)) or
 176             $self->meta->
 177             throw_error("Values passed to _add_member_hash must be integer");
 178     } @kv;
 179     my @return;
 180     while (my ($key, $value) = splice @kv, 0, 2 ) {
 181         push @return,
 182             $self->{member_hash}{$key} = $value
 183     }
 184     wantarray ? return @return: return $return[0];
 185 }
 186
 187 =head2 $collection->universe
 188
 189
 190 =cut
 191
 192 has 'universe' => (is => 'ro',
 193                    isa => 'Debbugs::Collection',
 194                    required => 1,
 195                    builder => '_build_universe',
 196                    writer => '_set_universe',
 197                    predicate => 'has_universe',
 198                   );
 199
 200 sub _build_universe {
 201     # By default, the universe is myself
 202     return $_[0];
 203 }
 204
 205 sub clone {
 206     my $self = shift;
 207     my $new = bless { %{$self} }, ref $self;
 208     if ($self->_has_members) {
 209         $new->_set_members([$self->members]);
 210     }
 211     if ($self->_has_member_hash) {
 212         $new->_set_member_hash({%{$self->_member_hash}})
 213     }
 214     return $new;
 215 }
 216
 217 sub _shallow_clone {
 218     my $self = shift;
 219     return bless { %{$self} }, ref $self;
 220 }
 221
 222 sub limit {
 223     my $self = shift;
 224     my $limit = $self->_shallow_clone();
 225     # Set the universe to whatever my universe is (potentially myself)
 226     # $limit->_set_universe($self->universe);
 227     $limit->_set_members([]);
 228     $limit->_clear_member_hash();
 229     $limit->add($self->universe->get_or_add_by_key(@_)) if @_;
 230     return $limit;
 231 }
 232
 233 sub get_or_add_by_key {
 234     my $self = shift;
 235     return () unless @_;
 236     my @return;
 237     my @exists;
 238     my @need_to_add;
 239     for my $i (0..$#_) {
 240         # we assume that if it's already a blessed reference, that it's the
 241         # right object to return
 242         if (ref $_[$i]) {
 243             croak "Passed a reference instead of a key to get_or_add_by_key";
 244         }
 245         elsif ($self->_member_key_exists($_[$i])) {
 246             push @exists,$i;
 247         } else {
 248             push @need_to_add,$i;
 249         }
 250     }
 251     # create and add by key
 252     if (@need_to_add) {
 253         @return[@need_to_add] =
 254             $self->add_by_key(@_[@need_to_add]);
 255     }
 256     if (@exists) {
 257         @return[@exists] =
 258             $self->get(@_[@exists]);
 259     }
 260     # if we've only been asked to get or create one thing, then it's expected
 261     # that we are returning only one thing
 262     if (@_ == 1) {
 263         return $return[0];
 264     }
 265     return @return;
 266 }
 267
 268 has 'constructor_args' => (is => 'rw',
 269                            isa => 'ArrayRef',
 270                            lazy => 1,
 271                            builder => '_build_constructor_args',
 272                           );
 273
 274 sub _build_constructor_args {
 275     return [];
 276 }
 277
 278 sub add_by_key {
 279     my $self = shift;
 280     # we'll assume that add does the right thing. around this in subclasses
 281     return $self->add(@_);
 282 }
 283
 284 sub add {
 285     my $self = shift;
 286     my @members_added;
 287     for my $member (@_) {
 288         if (not defined $member) {
 289             confess("Undefined member to add");
 290         }
 291         push @members_added,$member;
 292         if ($self->exists($member)) {
 293             next;
 294         }
 295         $self->_add($member);
 296         $self->_add_member_hash($self->member_key($member),
 297                                 $self->count()-1,
 298                                );
 299     }
 300     return @members_added;
 301 }
 302
 303 use overload '+' => "combine",
 304     '""' => "CARP_TRACE";
 305
 306 sub combine {
 307     my $self = shift;
 308     my $return = $self->clone;
 309     $return->add($_->members) for @_;
 310     return $return;
 311 }
 312
 313 sub get {
 314     my $self = shift;
 315     my @res = map {$self->_get_member($_)}
 316         $self->_get_member_hash(@_);
 317     wantarray?@res:$res[0];
 318 }
 319
 320
 321 sub member_key {
 322     return $_[1];
 323 }
 324
 325 sub keys_of_members {
 326     my $self = shift;
 327     return $self->map(sub {$self->member_key($_)});
 328 }
 329
 330 sub exists {
 331     my $self = shift;
 332     return $self->_member_key_exists($self->member_key($_[0]));
 333 }
 334
 335 sub join {
 336     my $self = shift;
 337     my $joiner = shift;
 338     return CORE::join($joiner,$self->keys_of_members);
 339 }
 340
 341 sub _build_member_hash {
 342     my $self = shift;
 343     my $hash = {};
 344     my $i = 0;
 345     for my $member ($self->members) {
 346         $hash->{$self->member_key($member)} =
 347             $i++;
 348     }
 349     return $hash;
 350 }
 351
 352 sub CARP_TRACE {
 353     my $self = shift;
 354     my @members = $self->members;
 355     if (@members > 5) {
 356         @members = map {$self->member_key($_)}
 357             @members[0..4];
 358         push @members,'...';
 359     } else {
 360         @members = map {$self->member_key($_)} @members;
 361     }
 362     return __PACKAGE__.'={n_members='.$self->count().
 363         ',members=('.CORE::join(',',@members).')}';
 364 }
 365
 366
 367 __PACKAGE__->meta->make_immutable;
 368 no Mouse;
 369 1;
 370
 371 __END__
 372 # Local Variables:
 373 # indent-tabs-mode: nil
 374 # cperl-indent-level: 4
 375 # End: