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                       isa => 'HashRef[Int]',
  53                       lazy => 1,
  54                       reader => '_member_hash',
  55                       builder => '_build_member_hash',
  56                       clearer => '_clear_member_hash',
  57                       predicate => '_has_member_hash',
  58                       writer => '_set_member_hash',
  59                       handles => {_add_member_hash => 'set',
  60                                   _member_key_exists => 'exists',
  61                                   _get_member_hash => 'get',
  62                                  },
  63                      );
  64
  65 has 'universe' => (is => 'ro',
  66                    isa => 'Debbugs::Collection',
  67                    required => 1,
  68                    builder => '_build_universe',
  69                    writer => '_set_universe',
  70                    predicate => 'has_universe',
  71                   );
  72
  73 sub _build_universe {
  74     # By default, the universe is myself
  75     return $_[0];
  76 }
  77
  78 sub clone {
  79     my $self = shift;
  80     my $new = bless { %{$self} }, ref $self;
  81     if ($self->_has_members) {
  82         $new->_set_members([$self->members]);
  83     }
  84     if ($self->_has_member_hash) {
  85         $new->_set_member_hash({%{$self->_member_hash}})
  86     }
  87     return $new;
  88 }
  89
  90 sub limit {
  91     my $self = shift;
  92     my $limit = $self->clone();
  93     # Set the universe to whatever my universe is (potentially myself)
  94     # $limit->_set_universe($self->universe);
  95     $limit->_set_members([]);
  96     $limit->_clear_member_hash();
  97     $limit->add($self->universe->get_or_create(@_)) if @_;
  98     return $limit;
  99 }
 100
 101 sub get_or_create {
 102     my $self = shift;
 103     return () unless @_;
 104     my @return;
 105     my @exists;
 106     my @need_to_add;
 107     for my $i (0..$#_) {
 108         # we assume that if it's already a blessed reference, that it's the right
 109         if (blessed($_[$i])) {
 110             $return[$i] =
 111                 $_[$i];
 112         }
 113         elsif ($self->_member_key_exists($_[$i])) {
 114             push @exists,$i;
 115         } else {
 116             push @need_to_add,$i;
 117         }
 118     }
 119     # create and add by key
 120     if (@need_to_add) {
 121         @return[@need_to_add] =
 122             $self->add_by_key(@_[@need_to_add]);
 123     }
 124     if (@exists) {
 125         @return[@exists] =
 126             $self->get(@_[@exists]);
 127     }
 128     # if we've only been asked to get or create one thing, then it's expected
 129     # that we are returning only one thing
 130     if (@_ == 1) {
 131         return $return[0];
 132     }
 133     return @return;
 134 }
 135
 136 has 'constructor_args' => (is => 'rw',
 137                            isa => 'ArrayRef',
 138                            default => sub {[]},
 139                           );
 140
 141 sub add_by_key {
 142     my $self = shift;
 143     # we'll assume that add does the right thing. around this in subclasses
 144     return $self->add(@_);
 145 }
 146
 147 sub add {
 148     my $self = shift;
 149     my @members_added;
 150     for my $member (@_) {
 151         if (not defined $member) {
 152             confess("Undefined member to add");
 153         }
 154         push @members_added,$member;
 155         if ($self->exists($member)) {
 156             next;
 157         }
 158         $self->_add($member);
 159         $self->_add_member_hash($self->member_key($member),
 160                                 $self->count()-1,
 161                                );
 162     }
 163     return @members_added;
 164 }
 165
 166 sub get {
 167     my $self = shift;
 168     return $self->_get_member($self->_get_member_hash(@_));
 169 }
 170
 171
 172 sub member_key {
 173     return $_[1];
 174 }
 175
 176 sub exists {
 177     my $self = shift;
 178     return $self->_member_key_exists($self->member_key($_[0]));
 179 }
 180
 181 sub _build_member_hash {
 182     my $self = shift;
 183     my $hash = {};
 184     my $i = 0;
 185     for my $member ($self->members) {
 186         $hash->{$self->member_key($member)} =
 187             $i++;
 188     }
 189     return $hash;
 190 }
 191
 192 sub CARP_TRACE {
 193     my $self = shift;
 194     return 'Debbugs::Collection={n_members='.$self->count().'}';
 195 }
 196
 197
 198 __PACKAGE__->meta->make_immutable;
 199 no Mouse;
 200 1;
 201
 202 __END__
 203 # Local Variables:
 204 # indent-tabs-mode: nil
 205 # cperl-indent-level: 4
 206 # End: