X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCollection.pm;fp=Debbugs%2FCollection.pm;h=6e3d49d95ed9e30f3caca34035cb527be0a89e52;hb=b1252b6797aa6a79d00a32165fb2fa8fb1bd9318;hp=0000000000000000000000000000000000000000;hpb=06424150844462de782ae112aa26c80dfa8d9401;p=debbugs.git diff --git a/Debbugs/Collection.pm b/Debbugs/Collection.pm new file mode 100644 index 0000000..6e3d49d --- /dev/null +++ b/Debbugs/Collection.pm @@ -0,0 +1,390 @@ +# This module is part of debbugs, and +# is released under the terms of the GPL version 2, or any later +# version (at your option). See the file README and COPYING for more +# information. +# Copyright 2018 by Don Armstrong . + +package Debbugs::Collection; + +=head1 NAME + +Debbugs::Collection -- Collection base class which can generate lots of objects + +=head1 SYNOPSIS + +This base class is designed for holding collections of objects which can be +uniquely identified by a key and added/generated by that same key. + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; +use List::AllUtils qw(pairmap); +use Carp qw(croak); + +extends 'Debbugs::OOBase'; + +=head1 METHODS + +=head2 Debbugs::Collection->new(%params|$params) + +Creates a new Debbugs::Collection object. + +Parameters: + +=over + +=item universe + +To avoid unnecessarily constructing new members, collections have a universe to +which existing members can be obtained from. By default the universe is this +collection. Generally, you should create exactly one universe for each +collection type. + +=item schema + +Optional Debbugs::Schema object + + +=back + +=head2 $collection->members() + +Returns list of members of this collection + +=head2 $collection->members_ref() + +Returns an ARRAYREF of members of this collection + +=head2 $collection->keys_of_members() + +Returns a list of the keys of all members of this collection + +=head2 $collection->member_key($member) + +Given a member, returns the key of that member + +=head2 $collection->exists($member_key) + +Returns true if a member with $member_key exists in the collection + +=head2 $collection->clone() + +Returns a clone of this collection with the same universe as this collection + +=head2 $collection->limit(@member_keys) + +Returns a new collection limited to the list of member keys passed. Will add new +members to the universe if they do not currently exist. + +=head2 $collection->add($member) + +Add a member to this collection + +=head2 $collection->add_by_key($member_key) + +Add a member to this collection by key + +=head2 $collection->combine($collection2) or $collection + $collection2 + +Combines the members of both collections together and returns the new collection + +=head2 $collection->get($member_key) + +Get member(s) by key, returning undef for keys which do not exist in the +collection + +=head2 $collection->get_or_add_by_key($member_key) + +Get or add a member by the member key. + +=head2 $collection->count() + +Return the number of members in this collection + +=head2 $collection->grep({$_ eq 5}) + +Return the members in this collection which satisfy the condition, setting $_ +locally to each member object + +=head2 $collection->join(', ') + +Returns the keys of the members of this collection joined + +=head2 $collection->apply({$_*2}) + +Return the list of applying BLOCK to each member; each member can return 0 or +more results + +=head2 $collection->map({$_*2}) + +Returns the list of applying BLOCK to each member; each member should return +exactly one result + +=head2 $collection->sort({$a <=> $b}) + +Return the list of members sorted by BLOCK + +=cut + +has 'members' => (is => 'bare', + isa => 'ArrayRef', + traits => ['Array'], + default => sub {[]}, + writer => '_set_members', + predicate => '_has_members', + handles => {_add => 'push', + members => 'elements', + count => 'count', + _get_member => 'get', + grep => 'grep', + map => 'map', + sort => 'sort', + }, + ); + +sub apply { + my $self = shift; + my $block = shift; + my @r; + for ($self->members) { + push @r,$block->(); + } + return @r; +} + +sub members_ref { + my $self = shift; + return [$self->members]; +} + +has 'member_hash' => (traits => ['Hash'], + is => 'bare', + # really a HashRef[Int], but type checking is too slow + isa => 'HashRef', + lazy => 1, + reader => '_member_hash', + builder => '_build_member_hash', + clearer => '_clear_member_hash', + predicate => '_has_member_hash', + writer => '_set_member_hash', + handles => {# _add_member_hash => 'set', + _member_key_exists => 'exists', + _get_member_hash => 'get', + }, + ); + +# because _add_member_hash needs to be fast, we are overriding the default set +# method which is very safe but slow, because it makes copies. +sub _add_member_hash { + my ($self,@kv) = @_; + pairmap { + defined($a) + or $self->meta-> + throw_error("Hash keys passed to _add_member_hash must be defined" ); + ($b eq int($b)) or + $self->meta-> + throw_error("Values passed to _add_member_hash must be integer"); + } @kv; + my @return; + while (my ($key, $value) = splice @kv, 0, 2 ) { + push @return, + $self->{member_hash}{$key} = $value + } + wantarray ? return @return: return $return[0]; +} + +=head2 $collection->universe + + +=cut + +has 'universe' => (is => 'ro', + isa => 'Debbugs::Collection', + required => 1, + builder => '_build_universe', + writer => '_set_universe', + predicate => 'has_universe', + ); + +sub _build_universe { + # By default, the universe is myself + return $_[0]; +} + +sub clone { + my $self = shift; + my $new = bless { %{$self} }, ref $self; + if ($self->_has_members) { + $new->_set_members([$self->members]); + } + if ($self->_has_member_hash) { + $new->_set_member_hash({%{$self->_member_hash}}) + } + return $new; +} + +sub _shallow_clone { + my $self = shift; + return bless { %{$self} }, ref $self; +} + +sub limit { + my $self = shift; + my $limit = $self->_shallow_clone(); + # Set the universe to whatever my universe is (potentially myself) + # $limit->_set_universe($self->universe); + $limit->_set_members([]); + $limit->_clear_member_hash(); + $limit->add($self->universe->get_or_add_by_key(@_)) if @_; + return $limit; +} + +sub get_or_add_by_key { + my $self = shift; + return () unless @_; + my @return; + my @exists; + my @need_to_add; + for my $i (0..$#_) { + # we assume that if it's already a blessed reference, that it's the + # right object to return + if (ref $_[$i]) { + croak "Passed a reference instead of a key to get_or_add_by_key"; + } + elsif ($self->_member_key_exists($_[$i])) { + push @exists,$i; + } else { + push @need_to_add,$i; + } + } + # create and add by key + if (@need_to_add) { + @return[@need_to_add] = + $self->add_by_key(@_[@need_to_add]); + } + if (@exists) { + @return[@exists] = + $self->get(@_[@exists]); + } + # if we've only been asked to get or create one thing, then it's expected + # that we are returning only one thing + if (@_ == 1) { + return $return[0]; + } + return @return; +} + +has 'constructor_args' => (is => 'rw', + isa => 'ArrayRef', + lazy => 1, + builder => '_build_constructor_args', + ); + +sub _build_constructor_args { + return []; +} + +sub add_by_key { + my $self = shift; + # we'll assume that add does the right thing. around this in subclasses + return $self->add(@_); +} + +sub add { + my $self = shift; + my @members_added; + for my $member (@_) { + if (not defined $member) { + confess("Undefined member to add"); + } + push @members_added,$member; + if ($self->exists($member)) { + next; + } + $self->_add($member); + $self->_add_member_hash($self->member_key($member), + $self->count()-1, + ); + } + return @members_added; +} + +use overload '+' => "combine", + '""' => "CARP_TRACE"; + +sub combine { + my $self = shift; + my $return = $self->clone; + $return->add($_->members) for @_; + return $return; +} + +sub get { + my $self = shift; + my @res = map {$self->_get_member($_)} + $self->_get_member_hash(@_); + wantarray?@res:$res[0]; +} + + +sub member_key { + return $_[1]; +} + +sub keys_of_members { + my $self = shift; + return $self->map(sub {$self->member_key($_)}); +} + +sub exists { + my $self = shift; + return $self->_member_key_exists($self->member_key($_[0])); +} + +sub join { + my $self = shift; + my $joiner = shift; + return CORE::join($joiner,$self->keys_of_members); +} + +sub _build_member_hash { + my $self = shift; + my $hash = {}; + my $i = 0; + for my $member ($self->members) { + $hash->{$self->member_key($member)} = + $i++; + } + return $hash; +} + +sub CARP_TRACE { + my $self = shift; + my @members = $self->members; + if (@members > 5) { + @members = map {$self->member_key($_)} + @members[0..4]; + push @members,'...'; + } else { + @members = map {$self->member_key($_)} @members; + } + return __PACKAGE__.'={n_members='.$self->count(). + ',members=('.CORE::join(',',@members).')}'; +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: