package UR::Object::Set;
use strict;
use warnings;
use UR;
use List::MoreUtils qw(any);
our $VERSION = "0.40"; # 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 . ')';
}
# I'll neave this in here commented out for the future
# It's intended to keep 'count' for sets updated in real-time as objects are
# created/deleted/updated
#sub _load {
# my $class = shift;
# my $self = $class->SUPER::_load(@_);
#
# my $member_class_name = $rule->subject_class_name;
#
# my $rule = $self->rule
# my $rule_template = $rule->template;
#
# my @rule_properties = $rule_template->_property_names;
# my %rule_values = map { $_ => $rule->value_for($_) } @rule_properties;
#
# my %underlying_comparator_for_property = map { $_->property_name => $_ } $rule_template->get_underlying_rule_templates;
#
# my @aggregates = qw( count );
#
# $member_class_name->create_subscription(
# note => 'set monitor '.$self->id,
# priority => 0,
# callback => sub {
# # make sure the aggregate values get invalidated when objects change
# my @agg_set = @$self{aggregates};
# return unless exists(@agg_set); # returns only if none of the aggregates have values
#
# my ($changed_object, $changed_property, $old_value, $new_value) = @_;
#
# if ($changed_property eq 'create') {
# if ($rule->evaluate($changed_object)) {
# $self->{'count'}++;
# }
# } elsif ($changed_property eq 'delete') {
# if ($rule->evaluate($changed_object)) {
# $self->{'count'}--;
# }
# } elsif (exists $value_index_for_property{$changed_property}) {
#
# my $comparator = $underlying_comparator_for_property{$changed_property};
#
# # HACK!
# $changed_object->{$changed_property} = $old_value;
# my $evaled_before = $comparator->evaluate_subject_and_values($changed_object,$rule_values{$changed_property});
#
# $changed_object->{$changed_property} = $new_value;
# my $evaled_after = $comparator->evaluate_subject_and_values($changed_object,$rule_values{$changed_property});
#
# if ($evaled_before and ! $evaled_after) {
# $self->{'count'}--;
# } elsif ($evaled_after and ! $evaled_before) {
# $self->{'count'}++;
# }
# }
# }
# );
#
# return $self;
#}
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 _members_have_changes {
my $self = shift;
return any { $self->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 __aggregate__ {
my $self = shift;
my $f = shift;
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;
# If there are no member-class objects with changes, we can just interrogate the DB
if ($self->_members_have_changes or $not_ds_expressable) {
my $fname;
my @fargs;
if ($f =~ /^(\w+)\((.*)\)$/) {
$fname = $1;
@fargs = ($2 ? split(',',$2) : ());
}
else {
$fname = $f;
@fargs = ();
}
my $local_method = '__aggregate_' . $fname . '__';
$self->{$f} = $self->$local_method(@fargs);
}
elsif (! exists $self->{$f}) {
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
);
}
return $self->{$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 not defined $min or $v < $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 not defined $max or $v > $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;
if (@_) {
$f .= '(' . join(',',@_) . ')';
}
return $self->__aggregate__($f);
};
}
# 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;