libur-perl 0.430-1 / usr / share / perl5 / UR / Object / Set.pm

package UR::Object::Set;

use strict;
use warnings;
use UR;
use List::MoreUtils qw(any);
our $VERSION = "0.43"; # UR $VERSION;

our @CARP_NOT = qw( UR::Object::Type );

use overload ('""' => '__display_name__');
use overload ('==' => sub { $_[0] . ''  eq $_[1] . '' } );
use overload ('eq' => sub { $_[0] . ''  eq $_[1] . '' } );
use overload ('!=' => sub { $_[0] . ''  ne $_[1] . '' } );
use overload ('ne' => sub { $_[0] . ''  ne $_[1] . '' } );

class UR::Object::Set {
    is => 'UR::Value',
    is_abstract => 1,
    has => [
        rule                => { is => 'UR::BoolExpr', id_by => 'id' },
        rule_display        => { is => 'Text', via => 'rule', to => '__display_name__'},
        member_class_name   => { is => 'Text', via => 'rule', to => 'subject_class_name' },
        members             => { is => 'UR::Object', is_many => 1, is_calculated => 1 }
    ],
    doc => 'an unordered group of distinct UR::Objects'
};

# override the UR/system display name
# this is used in stringification overload
sub __display_name__ {
    my $self = shift;
    my %b = $self->rule->_params_list;
    my $s = Data::Dumper->new([\%b])->Terse(1)->Indent(0)->Useqq(1)->Dump;
    $s =~ s/\n/ /gs;
    $s =~ s/^\s*{//; 
    $s =~ s/\}\s*$//;
    $s =~ s/\"(\w+)\" \=\> / $1 => /g;
    return '(' . ref($self) . ' ' . $s . ')';
}

# When a set comes into existance, set up a subscription to monitor changes
# to the set's members
UR::Object::Set->create_subscription(
    method  => 'load',
    note    => 'set creation monitor',
    callback => sub {
        my $set = shift;
        my $rule = $set->rule;
        my %set_defining_attributes = map { $_ => 1 } $rule->template->_property_names();
        my $deps = $set->{__aggregate_deps} ||= {};

        $set->member_class_name->create_subscription(
            note        => 'set monitor '.$set->id,
            priority    => 0,
            callback    => sub {
                return unless exists($set->{__aggregates});  # nothing cached  yet

                my ($member, $attr_name, $before, $after) = @_;
                # load/unload won't affect aggregate values
                return if ($attr_name eq 'load' or $attr_name eq 'unload');

                # If a set-defining attribute changes, or an object matching
                # the set is created or deleted, then the set membership has
                # possibly changed.  Invalidate the whole aggregate cache.
                if (exists($set_defining_attributes{$attr_name})
                    ||
                    (   ($attr_name eq 'create' or $attr_name eq 'delete')
                        &&
                        $rule->evaluate($member)
                    )
                ) {
                    $set->__invalidate_cache__;
                    # A later call to _members_have_changes() would miss the case
                    # where a member becomes deleted or a member-defining attribute
                    # changes
                    $set->{__members_have_changes} = 1;

                }
                # if the changed attribute is a dependancy for a cached aggregation
                # value, and it's a set member...
                elsif ((my $dependant_aggregates = $deps->{$attr_name})
                        &&
                        $rule->evaluate($member)
                ) {
                    # remove the cached aggregates that depend on this attribute
                    delete @{$set->{__aggregates}}{@$dependant_aggregates};
                    # remove the dependancy records
                    delete @$deps{@$dependant_aggregates};
                    delete $deps->{$attr_name}
                }
            }
        );
    }
);

# When a transaction rolls back, it doesn't trigger subscriptions for the
# member objects as they get changed back to their original values.
# The safe thing is to set wipe out all Sets' aggregate caches :(
# It would be helpful if sets had a db_committed like other objects
# and we could just revert their values back to their db_committed values
UR::Context::Transaction->create_subscription(
    method  => 'rollback',
    note    => 'rollback set cache invalidator',
    callback => sub {
        delete(@$_{'__aggregates','__aggregate_deps','__members_have_changes'}) foreach UR::Object::Set->is_loaded();
    }
);

UR::Context->create_subscription(
    method => 'commit',
    callback => sub {
        my $worked = shift;
        return unless $worked;  # skip if the commit failed
        delete $_->{__members_have_changes} foreach UR::Object::Set->is_loaded();
    }
);


sub get_with_special_parameters {
    Carp::cluck("Getting sets by directly properties of their members method will be removed shortly because of ambiguity on the meaning of 'id'.  Please update the code which calls this.");
    my $class = shift;
    my $bx = shift;
    my @params = @_;

    my $member_class = $class;
    $member_class =~ s/::Set$//;

    my $rule = UR::BoolExpr->resolve($member_class, $bx->params_list, @params);

    return $class->get($rule->id);
}

sub members {
    my $self = shift;
    my $rule = $self->rule;
    while (@_) {
        $rule = $rule->add_filter(shift, shift);
    }
    return $self->member_class_name->get($rule);
}

sub member_iterator {
    my $self = shift;
    my $rule = $self->rule;
    while (@_) {
        $rule = $rule->add_filter(shift, shift);
    }
    return $self->member_class_name->create_iterator($rule);
}

sub _members_have_changes {
    my $self = shift;
    return 1 if $self->{__members_have_changes};
    my $rule = $self->rule;
    return any { $rule->evaluate($_) && $_->__changes__(@_) } $self->member_class_name->is_loaded;
}

sub subset {
    my $self = shift;
    my $member_class_name = $self->member_class_name;
    my $bx = UR::BoolExpr->resolve($member_class_name,@_);
    my $subset = $self->class->get($bx->id);
    return $subset;
}

sub group_by {
    my $self = shift;
    my @group_by = @_;
    my $grouping_rule = $self->rule->add_filter(-group_by => \@group_by);
    my @groups = UR::Context->current->get_objects_for_class_and_rule( 
        $self->member_class_name, 
        $grouping_rule, 
        undef,  #$load, 
        0,      #$return_closure, 
    );
    return $self->context_return(@groups);
}


sub __invalidate_cache__ {
    my $self = shift;
    if (@_) {
        my $aggregate = shift;
        delete $self->{__aggregates}->{$aggregate};
    } else {
        delete @$self{'__aggregates','__aggregate_deps'};
    }
}

sub __aggregate__ {
    my $self = shift;
    my $aggr = shift;

    my $f = $aggr->{f};
    my $aggr_properties = $aggr->{properties};

    Carp::croak("$f is a group operation, and is not writable") if @_;

    my $subject_class_meta = $self->rule->subject_class_name->__meta__;

    my $not_ds_expressable = grep { $_->is_calculated or $_->is_transient or $_->is_constant }
                             map { $_->final_property_meta or $_ }
                             map { $subject_class_meta->property_meta_for_name($_) || () }
                             $self->rule->template->_property_names;

    my($cache, $deps) = @$self{'__aggregates','__aggregate_deps'};

    # If there are no member-class objects with changes, we can just interrogate the DB
    if (! exists($cache->{$f})) {
        if ($not_ds_expressable or $self->_members_have_changes(@$aggr_properties)) {
            my $fname;
            my @fargs;
            if ($f =~ /^(\w+)\((.*)\)$/) {
                $fname = $1;
                @fargs = ($2 ? split(',',$2) : ());
            }
            else {
                $fname = $f;
                @fargs = ();
            }
            my $local_method = '__aggregate_' . $fname . '__';
            $self->{__aggregates}->{$f} = $self->$local_method(@fargs);

        } else {
            my $rule = $self->rule->add_filter(-aggregate => [$f])->add_filter(-group_by => []);
            UR::Context->current->get_objects_for_class_and_rule(
                  $self->member_class_name,
                  $rule,
                  1,    # load
                  0,    # return_closure
             );

        }
        # keep 2-way mapping of dependances...
        # First, keep a list of properties this aggregate cached value depends on
        $deps->{$f} = $aggr_properties;
        # And add this aggregate to the lists these properties are dependancies for
        foreach ( @$aggr_properties ) {
            $deps->{$_} ||= [];
            push @{$deps->{$_}}, $f;
        }
    }
    return $self->{__aggregates}->{$f};
}

sub __aggregate_count__ {
    my $self = shift;
    my @members = $self->members;
    return scalar(@members);
}

sub __aggregate_min__ {
    my $self = shift;
    my $p = shift;
    my $min = undef;
    no warnings;
    for my $member ($self->members) {
        my $v = $member->$p;
        next unless defined $v;
        $min = $v if (!defined($min) || ($v < $min) || ($v lt $min));
    }
    return $min;
}

sub __aggregate_max__ {
    my $self = shift;
    my $p = shift;
    my $max = undef;
    no warnings;
    for my $member ($self->members) {
        my $v = $member->$p;
        next unless defined $v;
        $max = $v if (!defined($max) || ($v > $max) || ($v gt $max));
    }
    return $max;
}

sub __aggregate_sum__ {
    my $self = shift;
    my $p = shift;
    my $sum = undef;
    no warnings;
    for my $member ($self->members) {
        my $v = $member->$p;
        next unless defined $v;
        $sum += $v;
    }
    return $sum;
}

sub __related_set__ {
    my $self = $_[0];
    my $property_name = $_[1];
    my $bx1 = $self->rule;
    my $bx2 = $bx1->reframe($property_name);
    return $bx2->subject_class_name->define_set($bx2);
}

require Class::AutoloadCAN;
Class::AutoloadCAN->import();

sub CAN {
    my ($class,$method,$self) = @_;
    
    if ($method =~ /^__aggregate_(.*)__/) {
        # prevent circularity issues since this actually calls ->can();
        return;
    }


    my $member_class_name = $class;
    $member_class_name =~ s/::Set$//g; 
    return unless $member_class_name; 

    my $is_class_method = !ref($self);
    my $member_method_closure = $member_class_name->can($method);
    if ($is_class_method && $member_method_closure) {
        # We should only get here if the Set class has not implemented the method.
        # In which case we will delegate to the member class.
        return sub {
            my $self = shift;
            return $member_method_closure->($member_class_name, @_);
        };
    }

    if ($member_method_closure) {
        my $member_class_meta = $member_class_name->__meta__;
        my $member_property_meta = $member_class_meta->property_meta_for_name($method);
        
        # regular property access
        if ($member_property_meta) {
            return sub {
                my $self = shift;
                if (@_) {
                    Carp::croak("Cannot use method $method as a mutator: Set properties are not mutable");
                }
                my $rule = $self->rule;
                if ($rule->specifies_value_for($method)) {
                    return $rule->value_for($method);
                } 
                else {
                    my @members = $self->members;
                    my @values = map { $_->$method } @members;
                    return @values if wantarray;
                    return if not defined wantarray;
                    Carp::confess("Multiple matches for $class method '$method' called in scalar context.  The set has ".scalar(@values)." values to return") if @values > 1 and not wantarray;
                    return $values[0];
                }
            }; 
        }

        # set relaying with $s->foo_set->bar_set->baz_set;
        if (my ($property_name) = ($method =~ /^(.*)_set$/)) {
            return sub {
                shift->__related_set__($property_name, @_)
            }
        }

        # other method
        return sub {
            my $self = shift;
            if (@_) {
                Carp::croak("Cannot use method $method as a mutator: Set properties are not mutable");
            }
            my @members = $self->members;
            my @values = map { $_->$method } @members;
            return @values if wantarray;
            return if not defined wantarray;
            Carp::confess("Multiple matches for $class method '$method' called in scalar context.  The set has ".scalar(@values)." values to return") if @values > 1 and not wantarray;
            return $values[0];
        }; 

    }
    else {
        # a possible aggregation function
        # see if the method ___aggregate__ uses exists, and if so, delegate to __aggregate__
        # TODO: delegate these to aggregation function modules instead of having them in this module
        my $aggregator = '__aggregate_' . $method . '__';
        if ($self->can($aggregator)) {
            return sub {
                my $self = shift;
                my $f = $method;
                my @aggr_properties = @_;
                if (@aggr_properties) {
                    $f .= '(' . join(',',@aggr_properties) . ')';
                }
                return $self->__aggregate__({ f => $f, properties => \@aggr_properties });
            };
        }
        
        # set relaying with $s->foo_set->bar_set->baz_set;
        if (my ($property_name) = ($method =~ /^(.*)_set$/)) {
            return sub {
                shift->__related_set__($property_name, @_)
            }
        }
    }
    return;
}

1;