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