+++ /dev/null
-# 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 <don@donarmstrong.com>.
-
-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:
projects / debbugs.git / blobdiff