X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FCollection.pm;fp=Debbugs%2FCollection.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=6e3d49d95ed9e30f3caca34035cb527be0a89e52;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/Collection.pm b/Debbugs/Collection.pm deleted file mode 100644 index 6e3d49d..0000000 --- a/Debbugs/Collection.pm +++ /dev/null @@ -1,390 +0,0 @@ -# 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: