File Coverage

blib/lib/Farly/Object/Aggregate.pm

Criterion	Covered	Total	%
statement	92	93	98.9
branch	25	30	83.3
condition			n/a
subroutine	16	16	100.0
pod	8	9	88.8
total	141	148	95.2

package Farly::Object::Aggregate;
use 5.008008;
use strict;
use warnings;
use Carp;
require Exporter;
require Farly::Object::List;

our @ISA       = qw(Exporter);
our @EXPORT_OK = qw(NEXTVAL);

our $VERSION = '0.26';

sub new {
    my ( $class, $container ) = @_;

    confess "container object required"
      unless ( defined($container) );

    confess "Farly::Object::List object required"
      unless ( $container->isa('Farly::Object::List') );

    my $self = {
        CONTAINER => $container,    # input
        GROUPED   => undef,         # @array of objects grouped by identity
    };

    bless $self, $class;

    return $self;
}

sub container {
    return $_[0]->{'CONTAINER'};
}

sub iter {
    return @{ $_[0]->{'GROUPED'} };
}

sub NEXTVAL { $_[0]->() }

# iterator over the aggregate identities
sub id_iterator {
    my ($self) = @_;

    my @arr = $self->iter();
    my $i   = 0;

    # the iterator code ref
    return sub {
        return undef if ( $i == scalar(@arr) );

        my $object = Farly::Object->new();

        foreach my $property ( $arr[$i]->get_keys() ) {
            if ( $property ne '__AGG__' ) {
                $object->set( $property, $arr[$i]->get($property) );
            }
        }

        $i++;

        return $object;
      }
}

sub list_iterator {
    my ($self) = @_;

    my @arr = $self->iter();
    my $i   = 0;

    # the iterator code ref
    return sub {
        return undef if ( $i == scalar(@arr) );
        my $set = $arr[$i]->get('__AGG__');
        $i++;
        return $set;
      }
}

# CONTAINER objects which have defined all keys
# return \@array
sub _has_defined_keys {
    my ( $self, $keys ) = @_;

    my @r;

    foreach my $obj ( $self->container->iter() ) {

        my $all_keys_defined = 1;

        foreach my $key (@$keys) {
            if ( !$obj->has_defined($key) ) {
                $all_keys_defined = undef;
                last;
            }
            if ( !$obj->get($key)->can('compare') ) {

                #warn "$self skipped ", $obj->dump(), " in groupby\n";
                $all_keys_defined = undef;
                last;
            }
        }

        if ($all_keys_defined) {
            push @r, $obj;
        }
    }

    return \@r;
}

# [ {  KEY1 => value object,
#      KEY2 => value object,
#   __AGG__ => Farly::Object::List }, ]
# __AGG__ is a set of all objects sharing the
# common identity formed by KEY1 and KEY2,
# i.e $obj1->{KEY1} equals $obj2->{KEY1}
# and $obj1->{KEY2} equals $obj2->{KEY2}
# for all objects in __AGG__

sub groupby {
    my ($self) = shift;
    my @keys = @_;

    confess "a list of keys is required"
      unless ( scalar(@keys) > 0 );

    # $list will include objects that have defined all @keys
    my $list = $self->_has_defined_keys( \@keys );

    # check list size?

    my @sorted = sort {

        my $r;
        foreach my $key (@keys) {
            $r = $a->get($key)->compare( $b->get($key) );
            return $r if ( $r != 0 );
        }
        return $r;

    } @$list;

    my @grouped;

    for ( my $i = 0 ; $i != scalar(@sorted) ; $i++ ) {

        my $root = Farly::Object->new();

        foreach my $key (@keys) {
            $root->set( $key, $sorted[$i]->get($key) );
        }

        my $result = Farly::Object::List->new();

        my $j = $i;

        while ( $sorted[$j]->matches($root) ) {

            $result->add( $sorted[$j] );

            $j++;

            last() if $j == scalar(@sorted);
        }

        $i = $j - 1;

        $root->set( '__AGG__', $result );

        push @grouped, $root;
    }

    $self->{'GROUPED'} = \@grouped;
}

# input = search object
# return the __AGG__ object on first match
sub matches {
    my ( $self, $search ) = @_;

    foreach my $object ( $self->iter() ) {
        if ( $object->matches($search) ) {
            return $object->get('__AGG__');
        }
    }

    #return an empty List on no match
    return Farly::Object::List->new();
}

# input = search object and new __AGG__
sub update {
    my ( $self, $search, $list ) = @_;

    confess "Farly::Object::List required"
      unless defined($list);

    confess "Farly::Object::List required"
      unless $list->isa('Farly::Object::List');

    foreach my $object ( $self->iter() ) {
        if ( $object->matches($search) ) {
            $object->set( '__AGG__', $list );
            return;
        }
    }

    confess $search->dump(), " not found";
}

1;
__END__