our
$VERSION
=
"0.47"
;
UR::Object::Type->define(
class_name
=>
'UR::Context'
,
is_abstract
=> 1,
has
=> [
parent
=> {
is
=>
'UR::Context'
,
id_by
=>
'parent_id'
,
is_optional
=> 1 },
query_underlying_context
=> {
is
=>
'Boolean'
,
is_optional
=> 1,
default_value
=>
undef
,
doc
=>
'Flag indicating whether the context must (1), must not (0) or may (undef) query underlying contexts when handling a query'
},
],
valid_signals
=> [
qw(precommit sync_databases commit prerollback rollback)
],
doc
=>
<<EOS
The environment in which all data examination and change occurs in UR. The current context represents the current
state of everything, and acts as a manager/intermediary between the current application and underlying database(s).
This is responsible for mapping object requests to database requests, managing caching, transaction
consistency, locking, etc. by delegating to the correct components to handle these tasks.
EOS
);
our
@CARP_NOT
=
qw( UR::Object::Iterator Class::AutoloadCAN )
;
our
$all_objects_loaded
||= {};
our
$all_change_subscriptions
||= {};
our
$all_objects_are_loaded
||= {};
our
$all_params_loaded
||= {};
our
$all_objects_cache_size
||= 0;
our
$cache_last_prune_serial
||= 0;
our
$cache_size_highwater
;
our
$cache_size_lowwater
;
our
$GET_COUNTER
= 1;
our
$light_cache
= 0;
$UR::Context::current
= __PACKAGE__;
our
$initialized
= 0;
sub
_initialize_for_current_process {
my
$class
=
shift
;
if
(
$initialized
) {
die
"Attempt to re-initialize the current process?"
;
}
my
$root_id
=
$ENV
{UR_CONTEXT_ROOT} ||=
'UR::Context::DefaultRoot'
;
$UR::Context::root
= UR::Context::Root->get(
$root_id
);
unless
(
$UR::Context::root
) {
die
"Failed to find root context object '$root_id':!? Odd value in environment variable UR_CONTEXT_ROOT?"
;
}
if
(
my
$base_id
=
$ENV
{UR_CONTEXT_BASE}) {
$UR::Context::base
= UR::Context::Process->get(
$base_id
);
unless
(
$UR::Context::base
) {
die
"Failed to find base context object '$base_id':!? Odd value in environment variable UR_CONTEXT_BASE?"
;
}
}
else
{
$UR::Context::base
=
$UR::Context::root
;
}
$UR::Context::process
= UR::Context::Process->_create_for_current_process(
parent_id
=>
$UR::Context::base
->id);
if
(
exists
$ENV
{
'UR_CONTEXT_CACHE_SIZE_LOWWATER'
} ||
exists
$ENV
{
'UR_CONTEXT_CACHE_SIZE_HIGHWATER'
}) {
$cache_size_highwater
=
$ENV
{
'UR_CONTEXT_CACHE_SIZE_HIGHWATER'
} || 0;
$cache_size_lowwater
=
$ENV
{
'UR_CONTEXT_CACHE_SIZE_LOWWATER'
} || 0;
manage_objects_may_go_out_of_scope();
}
$UR::Context::current
=
$UR::Context::process
;
if
(
exists
$ENV
{
'UR_CONTEXT_MONITOR_QUERY'
}) {
$UR::Context::current
->monitor_query(
$ENV
{
'UR_CONTEXT_MONITOR_QUERY'
});
}
$initialized
= 1;
return
$UR::Context::current
;
}
my
$objects_may_go_out_of_scope
= 0;
sub
objects_may_go_out_of_scope {
if
(
@_
) {
$objects_may_go_out_of_scope
=
shift
;
}
return
$objects_may_go_out_of_scope
;
}
sub
manage_objects_may_go_out_of_scope {
if
((
defined
(
$cache_size_highwater
) and
$cache_size_highwater
> 0)
or
$light_cache
or
UR::Context::AutoUnloadPool->_pool_count
) {
objects_may_go_out_of_scope(1);
}
else
{
objects_may_go_out_of_scope(0);
}
}
*get_current
= \
¤t
;
sub
current {
return
$UR::Context::current
;
}
sub
process {
return
$UR::Context::process
;
}
sub
date_template {
return
q|%Y-%m-%d %H:%M:%S|
;
}
sub
now {
return
Date::Format::time2str(date_template(),
time
());
}
my
$master_monitor_query
= 0;
sub
monitor_query {
return
if
$UR::Object::Type::bootstrapping
;
my
$self
=
shift
;
$self
=
$UR::Context::current
unless
(
ref
$self
);
if
(
@_
) {
if
(
ref
$self
) {
$self
->{
'monitor_query'
} =
shift
;
}
else
{
$master_monitor_query
=
shift
;
}
}
return
ref
(
$self
) ?
$self
->{
'monitor_query'
} :
$master_monitor_query
;
}
my
%_query_log_times
;
my
$query_logging_fh
= IO::Handle->new();
$query_logging_fh
->fdopen(
fileno
(STDERR),
'w'
);
$query_logging_fh
->autoflush(1);
sub
query_logging_fh {
$query_logging_fh
=
$_
[1]
if
@_
> 1;
return
$query_logging_fh
;
}
sub
_log_query_for_rule {
return
if
$UR::Object::Type::bootstrapping
;
my
$self
=
shift
;
my
(
$subject_class
,
$rule
,
$message
) =
@_
;
my
$monitor_level
;
return
unless
(
$monitor_level
=
$self
->monitor_query);
return
if
(
substr
(
$subject_class
, 0,4) eq
'UR::'
and
$monitor_level
< 2);
my
$elapsed_time
= 0;
if
(
defined
(
$rule
)) {
my
$time_now
= Time::HiRes::
time
();
if
(!
exists
$_query_log_times
{
$rule
->id}) {
$_query_log_times
{
$rule
->id} =
$time_now
;
}
else
{
$elapsed_time
=
$time_now
-
$_query_log_times
{
$rule
->id};
}
}
if
(
$elapsed_time
) {
$message
.=
sprintf
(
" Elapsed %.4f s"
,
$elapsed_time
);
}
$query_logging_fh
->
print
(
$message
.
"\n"
);
}
sub
_log_done_elapsed_time_for_rule {
my
(
$self
,
$rule
) =
@_
;
delete
$_query_log_times
{
$rule
->id};
}
sub
resolve_data_sources_for_class_meta_and_rule {
my
$self
=
shift
;
my
$class_meta
=
shift
;
my
$boolexpr
=
shift
;
my
$class_name
=
$class_meta
->class_name;
my
$data_source
;
if
(
$class_name
->isa(
'UR::DataSource::RDBMS::Entity'
)) {
my
$params
=
$boolexpr
->legacy_params_hash;
my
$namespace
;
if
(
$params
->{
'namespace'
}) {
$namespace
=
$params
->{
'namespace'
};
$data_source
=
$params
->{
'namespace'
} .
'::DataSource::Meta'
;
}
elsif
(
$params
->{
'data_source'
} &&
!
ref
(
$params
->{
'data_source'
}) &&
$params
->{
'data_source'
}->can(
'get_namespace'
)) {
$namespace
=
$params
->{
'data_source'
}->get_namespace;
$data_source
=
$namespace
.
'::DataSource::Meta'
;
}
elsif
(
$params
->{
'data_source'
} &&
ref
(
$params
->{
'data_source'
}) eq
'ARRAY'
) {
my
%namespaces
=
map
{
$_
->
get_namespace
=> 1 } @{
$params
->{
'data_source'
}};
unless
(
scalar
(
keys
%namespaces
) == 1) {
Carp::confess(
"get() across multiple namespaces is not supported"
);
}
$namespace
=
$params
->{
'data_source'
}->[0]->get_namespace;
$data_source
=
$namespace
.
'::DataSource::Meta'
;
}
else
{
Carp::confess(
"Required parameter (namespace or data_source_id) missing"
);
}
if
(
my
$exists
= UR::Object::Type->get(
$data_source
)) {
$data_source
=
$data_source
->get();
}
else
{
$self
->warning_message(
"no data source $data_source: generating for $namespace..."
);
UR::DataSource::Meta->generate_for_namespace(
$namespace
);
$data_source
=
$data_source
->get();
}
unless
(
$data_source
) {
Carp::confess
"Failed to find or generate a data source for meta data for namespace $namespace!"
;
}
}
else
{
$data_source
=
$class_meta
->data_source;
}
if
(
$data_source
) {
$data_source
=
$data_source
->resolve_data_sources_for_rule(
$boolexpr
);
}
return
$data_source
;
}
sub
resolve_data_source_for_object {
my
$self
=
shift
;
my
$object
=
shift
;
my
$class_meta
=
$object
->__meta__;
my
$class_name
=
$class_meta
->class_name;
if
(
$class_name
->isa(
'UR::DataSource::RDBMS::Entity'
) ||
$class_name
->isa(
'UR::DataSource::RDBMS::Entity::Ghost'
)) {
my
$data_source
=
$object
->data_source;
my
(
$namespace
) = (
$data_source
=~ m/(^\w+?)::DataSource/);
unless
(
$namespace
) {
Carp::croak(
"Can't resolve data source for object of type $class_name: The object's namespace could not be inferred from its data_source $data_source"
);
}
my
$ds_name
=
$namespace
.
'::DataSource::Meta'
;
return
$ds_name
->get();
}
my
$ds
=
$class_meta
->data_source;
return
$ds
;
}
sub
_light_cache {
if
(
@_
> 1) {
$light_cache
=
$_
[1];
manage_objects_may_go_out_of_scope();
}
return
$light_cache
;
}
sub
infer_property_value_from_rule {
my
(
$self
,
$wanted_property_name
,
$rule
) =
@_
;
if
(
$rule
->specifies_value_for(
$wanted_property_name
)) {
return
$rule
->value_for(
$wanted_property_name
);
}
my
$subject_class_name
=
$rule
->subject_class_name;
my
$subject_class_meta
= UR::Object::Type->get(
$subject_class_name
);
my
$wanted_property_meta
=
$subject_class_meta
->property_meta_for_name(
$wanted_property_name
);
unless
(
$wanted_property_meta
) {
$self
->error_message(
"Class $subject_class_name has no property named $wanted_property_name"
);
return
;
}
if
(
$wanted_property_meta
->is_delegated) {
$self
->context_return(
$self
->_infer_delegated_property_from_rule(
$wanted_property_name
,
$rule
));
}
else
{
$self
->context_return(
$self
->_infer_direct_property_from_rule(
$wanted_property_name
,
$rule
));
}
}
my
%changes_not_counted
=
map
{
$_
=> 1 }
qw(load define unload query connect)
;
sub
add_change_to_transaction_log {
my
(
$self
,
$subject
,
$property
,
@data
) =
@_
;
my
(
$class
,
$id
);
if
(
ref
(
$subject
)) {
$class
=
ref
(
$subject
);
$id
=
$subject
->id;
unless
(
$changes_not_counted
{
$property
} ) {
$subject
->{_change_count}++;
}
}
else
{
$class
=
$subject
;
$subject
=
undef
;
$id
=
undef
;
}
if
(
$UR::Context::Transaction::log_all_changes
) {
UR::Context::Transaction->log_change(
$subject
,
$class
,
$id
,
$property
,
@data
);
}
if
(
my
$index_list
=
$UR::Object::Index::all_by_class_name_and_property_name
{
$class
}{
$property
}) {
unless
(
$property
eq
'create'
or
$property
eq
'load'
or
$property
eq
'define'
) {
for
my
$index
(
@$index_list
) {
$index
->_remove_object(
$subject
,
{
$property
=>
$data
[0] }
)
}
}
unless
(
$property
eq
'delete'
or
$property
eq
'unload'
) {
for
my
$index
(
@$index_list
) {
$index
->_add_object(
$subject
)
}
}
}
}
our
$sig_depth
= 0;
my
%subscription_classes
;
sub
send_notification_to_observers {
my
(
$self
,
$subject
,
$property
,
@data
) =
@_
;
my
(
$class
,
$id
);
if
(
ref
(
$subject
)) {
$class
=
ref
(
$subject
);
$id
=
$subject
->id;
}
else
{
$class
=
$subject
;
}
my
$check_classes
=
$subscription_classes
{
$class
};
unless
(
$check_classes
) {
$subscription_classes
{
$class
} =
$check_classes
= [
$class
? (
$class
,
(
grep
{
$_
->isa(
"UR::Object"
) }
$class
->inheritance),
''
)
: (
''
)
];
}
my
@check_properties
= (
$property
? (
$property
,
''
) : (
''
) );
my
@check_ids
= (
defined
(
$id
) ? (
$id
,
''
) : (
''
) );
my
@matches
=
map
{
@$_
}
grep
{
defined
$_
}
map
{
defined
(
$id
) ?
@$_
{
@check_ids
} :
values
(
%$_
) }
grep
{
defined
$_
}
map
{
@$_
{
@check_properties
} }
grep
{
defined
$_
}
@$UR::Context::all_change_subscriptions
{
@$check_classes
};
return
unless
@matches
;
$sig_depth
++;
if
(
@matches
> 1) {
no
warnings;
@matches
=
sort
{
$a
->[2] <=>
$b
->[2] }
@matches
;
};
foreach
my
$callback_info
(
@matches
) {
my
(
$callback
,
$note
,
undef
,
$id
,
$once
) =
@$callback_info
;
UR::Observer->get(
$id
)->
delete
()
if
$once
;
$callback
->(
$subject
,
$property
,
@data
);
}
$sig_depth
--;
return
scalar
(
@matches
);
}
sub
query {
my
$self
=
shift
;
if
( ( !
ref
(
$self
) or !
$self
->query_underlying_context)
and ! Scalar::Util::blessed(
$_
[1])
) {
no
warnings;
if
(
exists
$UR::Context::all_objects_loaded
->{
$_
[0]}) {
my
$is_monitor_query
=
$self
->monitor_query;
if
(
defined
(
my
$obj
=
$UR::Context::all_objects_loaded
->{
$_
[0]}->{
$_
[1]})) {
if
(
$is_monitor_query
) {
$self
->_log_query_for_rule(
$_
[0],
undef
, Carp::shortmess(
"QUERY: class $_[0] by ID $_[1]"
));
$self
->_log_query_for_rule(
$_
[0],
undef
,
"QUERY: matched 1 cached object\nQUERY: returning 1 object\n\n"
);
}
$obj
->{
'__get_serial'
} =
$UR::Context::GET_COUNTER
++;
return
$obj
;
}
elsif
(
my
$subclasses
=
$UR::Object::Type::_init_subclasses_loaded
{
$_
[0]}) {
foreach
my
$subclass
(
@$subclasses
) {
if
(
exists
$UR::Context::all_objects_loaded
->{
$subclass
} and
my
$obj
=
$UR::Context::all_objects_loaded
->{
$subclass
}->{
$_
[1]}
) {
if
(
$is_monitor_query
) {
$self
->_log_query_for_rule(
$_
[0],
undef
, Carp::shortmess(
"QUERY: class $_[0] by ID $_[1]"
));
$self
->_log_query_for_rule(
$_
[0],
undef
,
"QUERY: matched 1 cached object in subclass $subclass\nQUERY: returning 1 object\n\n"
);
}
$obj
->{
'__get_serial'
} =
$UR::Context::GET_COUNTER
++;
return
$obj
;
}
}
}
}
};
my
$class
=
shift
;
if
(
ref
(
$class
)) {
my
@rvals
;
foreach
my
$prop
(
@_
) {
push
(
@rvals
,
$class
->
$prop
());
}
if
(
wantarray
) {
return
@rvals
;
}
else
{
return
\
@rvals
;
}
}
my
(
$rule
,
@extra
) = UR::BoolExpr->resolve(
$class
,
@_
);
if
(
@extra
) {
if
(
scalar
@extra
== 2 and (
$extra
[0] eq
"sql"
or
$extra
[0] eq
'sql in'
)) {
return
$UR::Context::current
->_get_objects_for_class_and_sql(
$class
,
$extra
[1]);
}
return
$class
->get_with_special_parameters(
$rule
,
@extra
);
}
if
(!
$rule
->has_meta_options and (
$class
->isa(
"UR::Object::Type"
) or
$class
->isa(
"UR::Singleton"
) or
$class
->isa(
"UR::DataSource::QueryPlan"
))) {
my
$normalized_rule
=
$rule
->normalize;
my
@objects
=
$class
->_load(
$normalized_rule
);
return
unless
defined
wantarray
;
return
@objects
if
wantarray
;
if
(
@objects
> 1 and
defined
(
wantarray
)) {
Carp::croak(
"Multiple matches for $class query called in scalar context. $rule matches "
.
scalar
(
@objects
).
" objects"
);
}
return
$objects
[0];
}
return
$UR::Context::current
->get_objects_for_class_and_rule(
$class
,
$rule
);
}
sub
_resolve_id_for_class_and_rule {
my
(
$self
,
$class_meta
,
$rule
) =
@_
;
my
$class
=
$class_meta
->class_name;
my
$id
;
my
@id_property_names
=
$class_meta
->id_property_names
or Carp::confess(
"No id property names for class ($class). This should not have happened."
);
if
(
@id_property_names
== 1 ) {
$id
=
$class_meta
->autogenerate_new_object_id(
$rule
);
unless
(
defined
$id
) {
$class
->error_message(
"Failed to auto-generate an ID for single ID property class ($class)"
);
return
;
}
}
else
{
my
@missed_names
;
for
my
$name
(
@id_property_names
) {
push
@missed_names
,
$name
unless
$rule
->specifies_value_for(
$name
);
}
if
(
@missed_names
) {
$class
->error_message(
"Attempt to create $class with multiple ids without these properties: "
.
join
(
', '
,
@missed_names
));
return
;
}
else
{
Carp::confess(
"Attempt to create $class failed to resolve id from underlying id properties."
);
}
}
return
$id
;
}
our
$construction_method
=
'create'
;
sub
_create_entity_from_abstract_class {
my
$self
=
shift
;
my
$class
=
shift
;
my
$class_meta
=
$class
->__meta__;
my
(
$rule
,
%extra
) = UR::BoolExpr->resolve_normalized(
$class
,
@_
);
my
$subclassify_by
=
$class_meta
->subclassify_by();
unless
(
defined
$subclassify_by
) {
Carp::croak(
"Can't call $construction_method on abstract class $class without a subclassify_by property"
);
}
my
$sub_class_name
=
$rule
->value_for(
$subclassify_by
);
unless
(
defined
$sub_class_name
) {
my
$property_meta
=
$class_meta
->property(
$subclassify_by
);
unless
(
$property_meta
) {
Carp::croak(
"Abstract class $class has subclassify_by $subclassify_by, but no property exists by that name"
);
}
if
(
$property_meta
->default_value) {
$sub_class_name
=
$property_meta
->default_value();
}
elsif
(
$property_meta
->is_calculated and
ref
(
$property_meta
->calculate) eq
'CODE'
) {
my
$calculate_from
=
$property_meta
->calculate_from;
my
@calculate_params
;
foreach
my
$prop_name
(
@$calculate_from
) {
unless
(
$rule
->specifies_value_for(
$prop_name
)) {
Carp::croak(
"Class $class subclassify_by calculation property '$subclassify_by' "
.
"requires '$prop_name' in the $construction_method() params\n"
.
"Params were: "
. UR::Util->display_string_for_params_list(
$rule
->params_list));
}
push
@calculate_params
,
$rule
->value_for(
$prop_name
);
}
my
$sub
=
$property_meta
->calculate;
unless
(
$sub
) {
Carp::croak(
"Can't use undefined value as subroutine reference while resolving "
.
"value for class $class calculated property '$subclassify_by'"
);
}
$sub_class_name
=
$sub
->(
@calculate_params
);
}
elsif
(
$property_meta
->is_calculated and !
ref
(
$property_meta
->calculate)) {
Carp::croak(
"Can't use a non-coderef as a calculation for class $class subclassify_by"
);
}
elsif
(
$property_meta
->is_delegated) {
my
@values
=
$self
->infer_property_value_from_rule(
$subclassify_by
,
$rule
);
if
(!
@values
) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Couldn't infer a value for indirect property '$subclassify_by' via rule $rule"
);
}
elsif
(
@values
> 1) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Infering a value for property '$subclassify_by' via rule $rule returned multiple values: "
.
join
(
', '
,
@values
));
}
else
{
$sub_class_name
=
$values
[0];
}
}
else
{
Carp::croak(
"Can't use undefined value as a subclass name for $class property '$subclassify_by'"
);
}
}
unless
(
defined
$sub_class_name
) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Can't use undefined value as a subclass name for param '$subclassify_by'"
);
}
if
(
$sub_class_name
eq
$class
) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Value for $subclassify_by cannot be the same as the original class"
);
}
unless
(
$sub_class_name
->isa(
$class
)) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Class $sub_class_name is not a subclass of $class"
);
}
return
$sub_class_name
->
$construction_method
(
@_
);
}
my
%memos
;
my
%memos2
;
sub
create_entity {
my
$self
=
shift
;
my
$class
=
shift
;
my
$memo
=
$memos
{
$class
};
unless
(
$memo
) {
my
$class_meta
=
$class
->__meta__;
my
@inheritance
=
reverse
(
$class_meta
,
$class_meta
->ancestry_class_metas);
my
%property_objects
;
my
%direct_properties
;
my
%indirect_properties
;
my
%set_properties
;
my
%default_values
;
my
%default_value_requires_query
;
my
%default_value_requires_call
;
my
%immutable_properties
;
my
@deep_copy_default_values
;
for
my
$co
(
@inheritance
) {
my
@property_objects
=
$co
->direct_property_metas;
my
@property_names
=
map
{
$_
->property_name }
@property_objects
;
@property_objects
{
@property_names
} =
@property_objects
;
foreach
my
$prop
(
@property_objects
) {
my
$name
=
$prop
->property_name;
unless
(
defined
$name
) {
Carp::confess(
"no name on property for class "
.
$co
->class_name .
"?\n"
. Data::Dumper::Dumper(
$prop
));
}
my
$default_value
=
$prop
->default_value;
if
(
defined
$default_value
) {
if
(
$prop
->data_type and
$prop
->_data_type_as_class_name eq
$prop
->data_type and
$prop
->_data_type_as_class_name->can(
"get"
)) {
$default_value_requires_query
{
$name
} =
$default_value
;
}
elsif
(
ref
(
$default_value
)) {
push
@deep_copy_default_values
,
$name
;
}
$default_values
{
$name
} =
$default_value
;
}
if
(
$prop
->calculated_default) {
$default_value_requires_call
{
$name
} =
$prop
->calculated_default;
}
if
(
$prop
->is_many) {
$set_properties
{
$name
} =
$prop
;
}
elsif
(
$prop
->is_delegated) {
$indirect_properties
{
$name
} =
$prop
;
}
else
{
$direct_properties
{
$name
} =
$prop
;
}
unless
(
$prop
->is_mutable) {
$immutable_properties
{
$name
} = 1;
}
}
}
my
@indirect_property_names
=
keys
%indirect_properties
;
my
@direct_property_names
=
keys
%direct_properties
;
my
@subclassify_by_methods
;
foreach
my
$co
(
@inheritance
) {
if
(
$class
ne
$co
->class_name
and
$co
->is_abstract
and
my
$method
=
$co
->subclassify_by
) {
push
@subclassify_by_methods
,
$method
;
}
}
$memos
{
$class
} =
$memo
= [
$class_meta
,
$class_meta
->first_sub_classification_method_name,
$class_meta
->is_abstract,
\
@inheritance
,
\
%property_objects
,
\
%direct_properties
,
\
%indirect_properties
,
\
%set_properties
,
\
%immutable_properties
,
\
@subclassify_by_methods
,
\
%default_values
,
(
@deep_copy_default_values
? \
@deep_copy_default_values
:
undef
),
\
%default_value_requires_query
,
\
%default_value_requires_call
,
];
}
my
(
$class_meta
,
$first_sub_classification_method_name
,
$is_abstract
,
$inheritance
,
$property_objects
,
$direct_properties
,
$indirect_properties
,
$set_properties
,
$immutable_properties
,
$subclassify_by_methods
,
$initial_default_values
,
$deep_copy_default_values
,
$default_value_requires_query
,
$initial_default_value_requires_call
,
) =
@$memo
;
if
(
$first_sub_classification_method_name
) {
my
$sub_class_name
=
$class
->
$first_sub_classification_method_name
(
@_
);
if
(
defined
(
$sub_class_name
) and (
$sub_class_name
ne
$class
)) {
unless
(
$sub_class_name
->can(
$construction_method
)) {
Carp::croak(
"Can't locate object method '$construction_method' via package '$sub_class_name' "
.
"while resolving proper subclass for $class during $construction_method"
);
}
return
$sub_class_name
->
$construction_method
(
@_
);
}
}
if
(
$is_abstract
) {
return
$self
->_create_entity_from_abstract_class(
$class
,
@_
);
}
my
$rule
= UR::BoolExpr->resolve(
$class
,
@_
);
my
$template
=
$rule
->template;
my
$params
= {
$rule
->_params_list,
$template
->extend_params_list_for_values(@{
$rule
->{
values
}}) };
if
(
my
$a
=
$template
->{_ambiguous_keys}) {
my
$p
=
$template
->{_ambiguous_property_names};
@$params
{
@$p
} =
delete
@$params
{
@$a
};
}
my
$id
=
$params
->{id};
unless
(
defined
$id
) {
$id
=
$self
->_resolve_id_for_class_and_rule(
$class_meta
,
$rule
);
unless
(
$id
) {
return
;
}
$rule
= UR::BoolExpr->resolve_normalized(
$class
,
%$params
,
id
=>
$id
);
$params
= {
$rule
->params_list }; ;
}
my
%default_value_requires_call
=
%$initial_default_value_requires_call
;
delete
@default_value_requires_call
{
keys
%$params
};
my
%default_values
=
%$initial_default_values
;
for
my
$name
(
keys
%$default_value_requires_query
) {
my
@id_by
;
if
(
my
$id_by
=
$property_objects
->{
$name
}->id_by) {
@id_by
= (
ref
(
$id_by
) ?
@$id_by
: (
$id_by
));
}
if
(
$params
->{
$name
}) {
delete
$default_values
{
$name
};
}
elsif
(
@$params
{
@id_by
}) {
for
my
$id_by
(
@id_by
) {
delete
$default_values
{
$id_by
}
if
exists
$params
->{
$id_by
};
}
delete
$default_values
{
$name
};
}
else
{
my
$query
=
$default_value_requires_query
->{
$name
};
my
@query
;
if
(
ref
(
$query
) eq
'HASH'
) {
@query
=
%$query
;
}
else
{
@query
= (
$query
);
}
my
$prop
=
$property_objects
->{
$name
};
my
$class
=
$prop
->_data_type_as_class_name;
eval
{
if
(
$prop
->is_many) {
$default_values
{
$name
} = [
$class
->get(
@query
) ];
}
else
{
$default_values
{
$name
} =
$class
->get(
@query
);
}
};
if
($@) {
warn
"error setting "
.
$prop
->class_name .
" "
.
$prop
->property_name .
" to default_value from query $query for type $class!"
;
};
}
}
if
(
$deep_copy_default_values
) {
for
my
$name
(
@$deep_copy_default_values
) {
if
(
$params
->{
$name
}) {
delete
$default_values
{
$name
};
}
else
{
$default_values
{
$name
} = UR::Util::deep_copy(
$default_values
{
$name
});
}
}
}
my
@extra
;
my
$indirect_values
= {};
for
my
$property_name
(
keys
%$indirect_properties
) {
if
(
exists
$params
->{
$property_name
} ) {
$indirect_values
->{
$property_name
} =
delete
$params
->{
$property_name
};
delete
$default_values
{
$property_name
};
}
elsif
(
exists
$default_values
{
$property_name
}) {
$indirect_values
->{
$property_name
} =
delete
$default_values
{
$property_name
};
}
}
my
%indirect_immutable_properties_via
;
for
my
$property_name
(
keys
%$indirect_values
) {
if
(
$immutable_properties
->{
$property_name
}) {
my
$meta
=
$indirect_properties
->{
$property_name
};
next
unless
$meta
;
my
$via
=
$meta
->via;
next
unless
$via
;
$indirect_immutable_properties_via
{
$via
}{
$property_name
} =
delete
$indirect_values
->{
$property_name
};
}
}
for
my
$via
(
keys
%indirect_immutable_properties_via
) {
my
$via_property_meta
=
$class_meta
->property_meta_for_name(
$via
);
my
(
$source_indirect_property
,
$source_value
) =
each
%{
$indirect_immutable_properties_via
{
$via
}};
unless
(
$via_property_meta
) {
Carp::croak(
"No metadata for class $class property $via while resolving indirect value for property $source_indirect_property"
);
}
my
$indirect_property_meta
=
$class_meta
->property_meta_for_name(
$source_indirect_property
);
unless
(
$indirect_property_meta
) {
Carp::croak(
"No metadata for class $class property $source_indirect_property while resolving indirect value for property $source_indirect_property"
);
}
unless
(
$indirect_property_meta
->to) {
(
$indirect_property_meta
) =
grep
{
$_
->property_name eq
$indirect_property_meta
->property_name }
$class_meta
->ancestry_property_metas();
unless
(
$indirect_property_meta
and
$indirect_property_meta
->to) {
Carp::croak(
"Can't resolve indirect relationship for possibly overridden property '$source_indirect_property'"
.
" in class $class. Parent classes have no property named '$source_indirect_property'"
);
}
}
my
$foreign_class
=
$via_property_meta
->data_type;
my
$foreign_property
=
$indirect_property_meta
->to;
my
$foreign_object
=
$foreign_class
->get(
$foreign_property
=>
$source_value
);
unless
(
$foreign_object
) {
$foreign_object
=
$foreign_class
->create(
$foreign_property
=>
$source_value
);
unless
(
$foreign_object
) {
Carp::croak(
"Can't create object of class $foreign_class with params ($foreign_property => '$source_value')"
.
" while resolving indirect value for class $class property $source_indirect_property"
);
}
}
my
@joins
=
$indirect_property_meta
->_resolve_join_chain();
my
%local_properties_to_set
;
foreach
my
$join
(
@joins
) {
if
(
$join
->{foreign_class}->isa(
"UR::Value"
)) {
next
;
}
for
(
my
$i
= 0;
$i
< @{
$join
->{
'source_property_names'
}};
$i
++) {
my
$source_property_name
=
$join
->{
'source_property_names'
}->[
$i
];
next
unless
(
exists
$direct_properties
->{
$source_property_name
});
my
$foreign_property_name
=
$join
->{
'foreign_property_names'
}->[
$i
];
my
$value
=
$foreign_object
->
$foreign_property_name
;
if
(
$rule
->specifies_value_for(
$source_property_name
)
and
$rule
->value_for(
$source_property_name
) ne
$value
)
{
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Conflicting values for property '$source_property_name'. $construction_method rule "
.
"specifies value '"
.
$rule
->value_for(
$source_property_name
) .
"' but "
.
"indirect immutable property '$source_indirect_property' with value "
.
"$source_value requires it to be '$value'"
);
}
$local_properties_to_set
{
$source_property_name
} =
$value
;
}
}
my
@param_keys
=
keys
%local_properties_to_set
;
@$params
{
@param_keys
} =
@local_properties_to_set
{
@param_keys
};
}
my
$set_values
= {};
for
my
$property_name
(
keys
%$set_properties
) {
if
(
exists
$params
->{
$property_name
}) {
delete
$default_values
{
$property_name
};
$set_values
->{
$property_name
} =
delete
$params
->{
$property_name
};
}
}
my
$entity
=
$self
->_construct_object(
$class
,
%default_values
,
%$params
,
@extra
);
return
unless
defined
$entity
;
$self
->add_change_to_transaction_log(
$entity
,
$construction_method
);
$self
->add_change_to_transaction_log(
$entity
,
'load'
)
if
$construction_method
eq
'__define__'
;
for
my
$property_name
(
keys
%default_value_requires_call
) {
my
$method
=
$default_value_requires_call
{
$property_name
};
my
$value
=
$method
->(
$entity
);
$entity
->
$property_name
(
$value
);
}
foreach
my
$property_name
(
keys
%$immutable_properties
) {
my
$property_meta
=
$property_objects
->{
$property_name
};
if
(!
exists
(
$params
->{
$property_name
}) and
$property_meta
and
$property_meta
->is_calculated) {
my
$value
=
$entity
->
$property_name
;
$params
->{
$property_name
} =
$value
;
}
}
for
my
$subclassify_by
(
@$subclassify_by_methods
) {
my
$param_value
=
$rule
->value_for(
$subclassify_by
);
$param_value
=
eval
{
$entity
->
$subclassify_by
}
unless
(
defined
$param_value
);
$param_value
=
$default_values
{
$subclassify_by
}
unless
(
defined
$param_value
);
if
(!
defined
$param_value
) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Can't use an undefined value as a subclass name for param '$subclassify_by'"
);
}
elsif
(
$param_value
ne
$class
) {
Carp::croak(
"Invalid parameters for $class->$construction_method(): "
.
"Value for subclassifying param '$subclassify_by' "
.
"($param_value) does not match the class it was called on ($class)"
);
}
}
if
(
%$set_values
) {
for
my
$property_name
(
keys
%$set_values
) {
my
$meta
=
$set_properties
->{
$property_name
};
my
$singular_name
=
$meta
->singular_name;
my
$adder
=
'add_'
.
$singular_name
;
my
$value
=
$set_values
->{
$property_name
};
unless
(
ref
(
$value
) eq
'ARRAY'
) {
$value
= [
$value
];
}
for
my
$item
(
@$value
) {
if
(
ref
(
$item
) eq
'ARRAY'
) {
$entity
->
$adder
(
@$item
);
}
elsif
(
ref
(
$item
) eq
'HASH'
) {
$entity
->
$adder
(
%$item
);
}
else
{
$entity
->
$adder
(
$item
);
}
}
}
}
if
(
%$indirect_values
) {
for
my
$property_name
(
keys
%$indirect_values
) {
$entity
->
$property_name
(
$indirect_values
->{
$property_name
});
}
}
if
(
%$immutable_properties
) {
my
@problems
=
$entity
->__errors__();
if
(
@problems
) {
my
@errors_fatal_to_construction
;
my
%problems_by_property_name
;
for
my
$problem
(
@problems
) {
my
@problem_properties
;
for
my
$name
(
$problem
->properties) {
if
(
$immutable_properties
->{
$name
}) {
push
@problem_properties
,
$name
;
}
}
if
(
@problem_properties
) {
push
@errors_fatal_to_construction
,
join
(
" and "
,
@problem_properties
) .
': '
.
$problem
->desc;
}
}
if
(
@errors_fatal_to_construction
) {
my
$msg
=
'Failed to $construction_method '
.
$class
.
' with invalid immutable properties:'
.
join
(
"\n"
,
@errors_fatal_to_construction
);
}
}
}
$entity
->__signal_observers__(
$construction_method
);
$entity
->__signal_observers__(
'load'
)
if
$construction_method
eq
'__define__'
;
$entity
->{
'__get_serial'
} =
$UR::Context::GET_COUNTER
++;
$UR::Context::all_objects_cache_size
++;
return
$entity
;
}
sub
_construct_object {
my
$self
=
shift
;
my
$class
=
shift
;
my
$params
= {
@_
};
my
$id
=
$params
->{id};
unless
(
defined
(
$id
)) {
Carp::confess(
"No ID specified (or incomplete id params) for $class _construct_object. Params were:\n"
. Data::Dumper::Dumper(
$params
)
);
}
if
(
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
}) {
$class
->error_message(
"An object of class $class already exists with id value '$id'"
);
return
;
}
my
$object
;
if
(
$object
=
$UR::DeletedRef::all_objects_deleted
->{
$class
}->{
$id
}) {
UR::DeletedRef->resurrect(
$object
);
%$object
=
%$params
;
}
else
{
$object
=
bless
$params
,
$class
;
}
if
(
my
$ghost
=
$UR::Context::all_objects_loaded
->{
$class
.
"::Ghost"
}->{
$id
}) {
if
(
my
$committed_data
=
$ghost
->{db_committed}) {
$object
->{db_committed} = {
%$committed_data
};
}
if
(
my
$unsaved_data
=
$ghost
->{
'db_saved_uncommitted'
}) {
$object
->{
'db_saved_uncommitted'
} = {
%$unsaved_data
};
}
$ghost
->__signal_change__(
"delete"
);
$self
->_abandon_object(
$ghost
);
}
$UR::Context::all_objects_loaded
->{
$class
}{
$id
} =
$object
;
if
(
$light_cache
) {
Scalar::Util::weaken(
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
});
}
return
$object
;
}
sub
delete_entity {
my
(
$self
,
$entity
) =
@_
;
if
(
ref
(
$entity
)) {
if
(
$entity
->{db_committed} ||
$entity
->{db_saved_uncommitted}) {
my
$do_data_source
;
my
%ghost_params
;
my
(
@prop_names
,
@many_prop_names
);
foreach
my
$prop_name
(
$entity
->__meta__->all_property_names) {
next
unless
exists
$entity
->{
$prop_name
};
if
(
$prop_name
eq
'data_source_id'
) {
$do_data_source
= 1;
next
;
}
if
(
ref
(
$entity
->{
$prop_name
}) eq
'ARRAY'
) {
push
@many_prop_names
,
$prop_name
;
}
else
{
push
@prop_names
,
$prop_name
;
}
}
@ghost_params
{
@prop_names
} =
$entity
->get(
@prop_names
);
foreach
my
$prop_name
(
@many_prop_names
) {
my
@values
=
$entity
->get(
$prop_name
);
$ghost_params
{
$prop_name
} = \
@values
;
}
if
(
$do_data_source
) {
$ghost_params
{
'data_source_id'
} =
$entity
->{
'data_source_id'
};
}
my
$ghost
=
$self
->_construct_object(
$entity
->ghost_class,
id
=>
$entity
->id,
%ghost_params
);
unless
(
$ghost
) {
Carp::confess(
"Failed to constructe a deletion record for an unsync'd delete."
);
}
$ghost
->__signal_change__(
"create"
);
for
my
$com
(
qw(db_committed db_saved_uncommitted)
) {
$ghost
->{
$com
} =
$entity
->{
$com
}
if
$entity
->{
$com
};
}
}
$entity
->__signal_change__(
'delete'
);
$self
->_abandon_object(
$entity
);
return
$entity
;
}
else
{
Carp::confess(
"Can't call delete as a class method."
);
}
}
sub
_abandon_object {
my
$self
=
shift
;
my
$object
=
$_
[0];
my
$class
=
$object
->class;
my
$id
=
$object
->id;
if
(
$object
->{
'__get_serial'
}) {
$UR::Context::all_objects_cache_size
--;
}
delete
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
};
delete
$UR::Context::all_objects_are_loaded
->{
$class
};
if
(
$object
->{
'__load'
}) {
while
(
my
(
$template_id
,
$rules
) =
each
%{
$object
->{
'__load'
}} ) {
foreach
my
$rule_id
(
keys
%$rules
) {
delete
$UR::Context::all_params_loaded
->{
$template_id
}->{
$rule_id
};
foreach
my
$fabricator
( UR::Context::ObjectFabricator->all_object_fabricators ) {
$fabricator
->delete_from_all_params_loaded(
$template_id
,
$rule_id
);
}
}
}
}
if
(
$ENV
{
'UR_DEBUG_OBJECT_RELEASE'
}) {
print
STDERR
"MEM DELETE object $object class "
,
$object
->class,
" id "
,
$object
->id,
"\n"
;
}
UR::DeletedRef->bury(
$object
);
return
$object
;
}
sub
_infer_direct_property_from_rule {
my
(
$self
,
$wanted_property_name
,
$rule
) =
@_
;
my
$rule_template
=
$rule
->template;
my
@properties_in_rule
=
$rule_template
->_property_names;
my
$subject_class_name
=
$rule
->subject_class_name;
my
$subject_class_meta
=
$subject_class_name
->__meta__;
my
(
$alternate_class
,
$alternate_get_property
,
$alternate_wanted_property
);
my
@r_values
;
PROPERTY_IN_RULE:
foreach
my
$property_name
(
@properties_in_rule
) {
my
$property_meta
=
$subject_class_meta
->property_meta_for_name(
$property_name
);
my
$final_property_meta
=
$property_meta
->final_property_meta ||
$property_meta
;
$alternate_get_property
=
$final_property_meta
->property_name;
$alternate_class
=
$final_property_meta
->class_name;
unless
(
$alternate_wanted_property
) {
$alternate_wanted_property
=
$wanted_property_name
;
$alternate_get_property
=
$property_name
;
$alternate_class
=
$subject_class_name
;
}
my
$value_from_rule
=
$rule
->value_for(
$property_name
);
my
@alternate_values
;
eval
{
my
@alternate_objects
=
$self
->query(
$alternate_class
,
$alternate_get_property
=>
$value_from_rule
);
@alternate_values
=
map
{
$_
->
$alternate_wanted_property
}
@alternate_objects
;
};
next
unless
(
@alternate_values
);
push
@r_values
, \
@alternate_values
;
}
if
(
@r_values
== 0) {
return
;
}
elsif
(
@r_values
== 1) {
return
@{
$r_values
[0]};
}
else
{
my
%intersection
=
map
{
$_
=> 1 } @{
shift
@r_values
};
foreach
my
$list
(
@r_values
) {
%intersection
=
map
{
$_
=> 1 }
grep
{
$intersection
{
$_
} }
@$list
;
}
return
keys
%intersection
;
}
}
sub
_infer_delegated_property_from_rule {
my
(
$self
,
$wanted_property_name
,
$rule
) =
@_
;
my
$rule_template
=
$rule
->template;
my
$subject_class_name
=
$rule
->subject_class_name;
my
$subject_class_meta
=
$subject_class_name
->__meta__;
my
$wanted_property_meta
=
$subject_class_meta
->property_meta_for_name(
$wanted_property_name
);
unless
(
$wanted_property_meta
->via) {
Carp::croak(
"There is no linking meta-property (via) on property $wanted_property_name on $subject_class_name"
);
}
my
$linking_property_meta
=
$subject_class_meta
->property_meta_for_name(
$wanted_property_meta
->via);
my
$final_property_meta
=
$wanted_property_meta
->final_property_meta;
if
(
$linking_property_meta
->reverse_as) {
eval
{
$linking_property_meta
->data_type->class() };
if
(
$linking_property_meta
->data_type ne
$final_property_meta
->class_name) {
Carp::croak(
"UR::Context::_infer_delegated_property_from_rule() doesn't handle multiple levels of indiretion yet"
);
}
}
my
@rule_translation
=
$linking_property_meta
->get_property_name_pairs_for_join();
my
%alternate_get_params
;
foreach
my
$pair
(
@rule_translation
) {
my
$rule_param
=
$pair
->[0];
next
unless
(
$rule_template
->specifies_value_for(
$rule_param
));
my
$alternate_param
=
$pair
->[1];
my
$value
=
$rule
->value_for(
$rule_param
);
$alternate_get_params
{
$alternate_param
} =
$value
;
}
my
$alternate_class
=
$final_property_meta
->class_name;
my
$alternate_wanted_property
=
$wanted_property_meta
->to;
my
@alternate_values
;
eval
{
my
@alternate_objects
=
$self
->query(
$alternate_class
,
%alternate_get_params
);
@alternate_values
=
map
{
$_
->
$alternate_wanted_property
}
@alternate_objects
;
};
return
@alternate_values
;
}
sub
object_cache_size_highwater {
my
$self
=
shift
;
if
(
@_
) {
my
$value
=
shift
;
$cache_size_highwater
=
$value
;
if
(
defined
$value
) {
if
(
$cache_size_lowwater
and
$value
<=
$cache_size_lowwater
) {
Carp::confess(
"Can't set the highwater mark less than or equal to the lowwater mark"
);
return
;
}
$self
->prune_object_cache();
}
manage_objects_may_go_out_of_scope();
}
return
$cache_size_highwater
;
}
sub
object_cache_size_lowwater {
my
$self
=
shift
;
if
(
@_
) {
my
$value
=
shift
;
$cache_size_lowwater
=
$value
;
if
(
defined
(
$value
) and
$cache_size_highwater
and
$value
>=
$cache_size_highwater
) {
Carp::confess(
"Can't set the lowwater mark greater than or equal to the highwater mark"
);
return
;
}
}
return
$cache_size_lowwater
;
}
sub
get_data_sources_for_loaded_classes {
my
$class
=
shift
;
my
%data_source_for_class
;
foreach
my
$class
(
keys
%$UR::Context::all_objects_loaded
) {
next
if
(
substr
(
$class
,0,-6) eq
'::Type'
);
next
unless
exists
$UR::Context::all_objects_loaded
->{
$class
.
'::Type'
};
my
$class_meta
=
$UR::Context::all_objects_loaded
->{
$class
.
'::Type'
}->{
$class
};
next
unless
$class_meta
;
next
unless
(
$class_meta
->is_uncachable());
$data_source_for_class
{
$class
} =
$class_meta
->data_source_id;
}
return
%data_source_for_class
;
}
our
$is_pruning
= 0;
sub
prune_object_cache {
my
$self
=
shift
;
return
if
(
$is_pruning
);
return
if
(!
defined
(
$cache_size_highwater
) or !
defined
(
$cache_size_lowwater
));
return
unless
(
$all_objects_cache_size
>
$cache_size_highwater
);
$is_pruning
= 1;
my
$t1
;
if
(
$ENV
{
'UR_DEBUG_OBJECT_RELEASE'
} ||
$ENV
{
'UR_DEBUG_OBJECT_PRUNING'
}) {
$t1
= Time::HiRes::
time
();
print
STDERR Carp::longmess(
"MEM PRUNE begin at $t1 "
,
scalar
(
localtime
(
$t1
)),
"\n"
);
}
my
$index_id_sep
= UR::Object::Index->__meta__->composite_id_separator() ||
"\t"
;
my
%data_source_for_class
=
$self
->get_data_sources_for_loaded_classes;
my
%indexes_by_class
;
foreach
my
$idx_id
(
keys
%{
$UR::Context::all_objects_loaded
->{
'UR::Object::Index'
}} ) {
my
$class
=
substr
(
$idx_id
, 0,
index
(
$idx_id
,
$index_id_sep
));
next
unless
exists
$data_source_for_class
{
$class
};
push
@{
$indexes_by_class
{
$class
}},
$UR::Context::all_objects_loaded
->{
'UR::Object::Index'
}->{
$idx_id
};
}
my
$deleted_count
= 0;
my
$pass
= 0;
$cache_size_highwater
= 1
if
(
$cache_size_highwater
< 1);
$cache_size_lowwater
= 1
if
(
$cache_size_lowwater
< 1);
my
$target_serial
=
$cache_last_prune_serial
;
my
$serial_range
= (
$GET_COUNTER
-
$target_serial
);
my
$max_passes
= 10;
my
$target_serial_increment
=
int
(
$serial_range
/
$max_passes
) + 1;
while
(
$all_objects_cache_size
>
$cache_size_lowwater
&&
$target_serial
<
$GET_COUNTER
) {
$pass
++;
$target_serial
+=
$target_serial_increment
;
my
@objects_to_prune
;
foreach
my
$class
(
keys
%data_source_for_class
) {
my
$objects_for_class
=
$UR::Context::all_objects_loaded
->{
$class
};
$indexes_by_class
{
$class
} ||= [];
foreach
my
$id
(
keys
(
%$objects_for_class
) ) {
my
$obj
=
$objects_for_class
->{
$id
};
next
unless
defined
$obj
;
if
(
$obj
->is_weakened
||
$obj
->is_prunable &&
$obj
->{__get_serial} &&
$obj
->{__get_serial} <=
$target_serial
) {
if
(
$ENV
{
'UR_DEBUG_OBJECT_RELEASE'
}) {
print
STDERR
"MEM PRUNE object $obj class $class id $id\n"
;
}
push
@objects_to_prune
,
$obj
;
$deleted_count
++;
}
}
}
$self
->_weaken_references_for_objects(\
@objects_to_prune
);
}
$is_pruning
= 0;
$cache_last_prune_serial
=
$target_serial
;
if
(
$ENV
{
'UR_DEBUG_OBJECT_RELEASE'
} ||
$ENV
{
'UR_DEBUG_OBJECT_PRUNING'
}) {
my
$t2
= Time::HiRes::
time
();
printf
(
"MEM PRUNE complete, $deleted_count objects marked after $pass passes in %.4f sec\n\n\n"
,
$t2
-
$t1
);
}
if
(
$all_objects_cache_size
>
$cache_size_lowwater
) {
Carp::carp
"After several passes of pruning the object cache, there are still $all_objects_cache_size objects"
;
if
(
$ENV
{
'UR_DEBUG_OBJECT_PRUNING'
}) {
warn
"Top 10 classes by object count:\n"
.
$self
->_object_cache_pruning_report;
}
}
return
1;
}
sub
_weaken_references_for_objects {
my
(
$self
,
$obj_list
) =
@_
;
Carp::croak(
'Argument to _weaken_references_to_objects must be an arrayref'
)
unless
ref
(
$obj_list
) eq
'ARRAY'
;
my
%indexes_by_class
;
foreach
my
$obj
(
@$obj_list
) {
my
$class
=
$obj
->class;
$indexes_by_class
{
$class
} ||= [ UR::Object::Index->get(
indexed_class_name
=>
$class
) ];
$_
->weaken_reference_for_object(
$obj
)
foreach
@{
$indexes_by_class
{
$class
}};
delete
$obj
->{__get_serial};
Scalar::Util::weaken(
$UR::Context::all_objects_loaded
->{
$class
}->{
$obj
->id});
$all_objects_cache_size
--;
}
}
sub
_object_cache_pruning_report {
my
$self
=
shift
;
my
$max_show
=
shift
;
$max_show
= 10
unless
defined
(
$max_show
);
my
@sorted_counts
=
sort
{
$b
->[1] <=>
$a
->[1] }
map
{ [
$_
=>
scalar
(
keys
%{
$UR::Context::all_objects_loaded
->{
$_
}}) ] }
grep
{ !
$_
->__meta__->is_meta_meta }
keys
%$UR::Context::all_objects_loaded
;
my
$message
=
''
;
for
(
my
$i
= 0;
$i
< 10 and
$i
<
@sorted_counts
;
$i
++) {
my
$class_name
=
$sorted_counts
[
$i
]->[0];
my
$count
=
$sorted_counts
[
$i
]->[1];
$message
.=
"$class_name: $count\n"
;
if
(
$ENV
{
'UR_DEBUG_OBJECT_PRUNING'
} > 1) {
my
$no_data_source
= 0;
my
$other_references
= 0;
my
$strengthened
= 0;
my
$has_changes
= 0;
my
$prunable
= 0;
my
$class_data_source
=
eval
{
$class_name
->__meta__->data_source_id; };
foreach
my
$obj
(
values
%{
$UR::Context::all_objects_loaded
->{
$class_name
}} ) {
next
unless
$obj
;
my
$is_prunable
= 1;
if
(!
$class_data_source
) {
$no_data_source
++;
$is_prunable
= 0;
}
if
(!
exists
$obj
->{
'__get_serial'
}) {
$other_references
++;
$is_prunable
= 0;
}
if
(
exists
$obj
->{
'__strengthened'
}) {
$strengthened
++;
$is_prunable
= 0;
}
if
(
$obj
->__changes__) {
$has_changes
++;
$is_prunable
= 0;
}
if
(
$is_prunable
) {
$prunable
++;
}
}
$message
.=
sprintf
(
"\tNo data source: %d other refs: %d strengthend: %d has changes: %d prunable: %d\n"
,
$no_data_source
,
$other_references
,
$strengthened
,
$has_changes
,
$prunable
);
}
}
return
$message
;
}
sub
value_for_object_property_in_underlying_context {
my
(
$self
,
$obj
,
$property_name
) =
@_
;
my
$saved
=
$obj
->{db_saved_uncommitted} ||
$obj
->{db_committed};
unless
(
$saved
) {
Carp::croak(
qq(No object found in underlying context)
);
}
return
$saved
->{
$property_name
};
}
sub
object_exists_in_underlying_context {
my
(
$self
,
$obj
) =
@_
;
return
if
(
$obj
->{
'__defined'
});
return
(
exists
(
$obj
->{
'db_committed'
}) ||
exists
(
$obj
->{
'db_saved_uncommitted'
}));
}
sub
_get_objects_for_class_and_or_rule {
my
(
$self
,
$class
,
$rule
,
$load
,
$return_closure
) =
@_
;
$rule
=
$rule
->normalize;
my
@u
=
$rule
->underlying_rules;
my
@results
;
for
my
$u
(
@u
) {
if
(
wantarray
or not
defined
wantarray
) {
push
@results
,
$self
->get_objects_for_class_and_rule(
$class
,
$u
,
$load
,
$return_closure
);
}
else
{
my
$result
=
$self
->get_objects_for_class_and_rule(
$class
,
$u
,
$load
,
$return_closure
);
push
@results
,
$result
;
}
}
if
(
$return_closure
) {
my
$object_sorter
=
$rule
->template->sorter();
my
@next
;
return
sub
{
for
(
my
$i
= 0;
$i
<
@results
;
$i
++) {
unless
(
defined
$next
[
$i
]) {
$next
[
$i
] =
$results
[
$i
]->();
unless
(
defined
$next
[
$i
]) {
splice
(
@results
,
$i
, 1);
splice
(
@next
,
$i
, 1);
redo
if
$i
<
@results
;
}
}
}
my
$lowest_slot
= 0;
for
(
my
$i
= 1;
$i
<
@results
;
$i
++) {
my
$cmp
=
$object_sorter
->(
$next
[
$lowest_slot
],
$next
[
$i
]);
if
(
$cmp
> 0) {
$lowest_slot
=
$i
;
}
elsif
(
$cmp
== 0) {
$next
[
$i
] =
undef
;
}
}
my
$retval
=
$next
[
$lowest_slot
];
$next
[
$lowest_slot
] =
undef
;
return
$retval
;
};
}
my
$last
= 0;
my
$plast
= 0;
my
$next
= 0;
@results
=
grep
{
$plast
=
$last
;
$last
=
$_
;
$plast
==
$_
? () : (
$_
) }
sort
@results
;
return
unless
defined
wantarray
;
return
@results
if
wantarray
;
if
(
@results
> 1) {
$self
->_exception_for_multi_objects_in_scalar_context(
$rule
,\
@results
);
}
return
$results
[0];
}
sub
get_objects_for_class_and_rule {
my
(
$self
,
$class
,
$rule
,
$load
,
$return_closure
) =
@_
;
my
$initial_load
=
$load
;
my
$rule_template
=
$rule
->template;
my
$group_by
=
$rule_template
->group_by;
if
(
ref
(
$self
) and !
defined
(
$load
)) {
$load
=
$self
->query_underlying_context;
}
if
(
$group_by
and
$rule_template
->order_by) {
my
%group_by
=
map
{
$_
=> 1 } @{
$rule
->template->group_by };
foreach
my
$order_by_property
( @{
$rule
->template->order_by } ) {
unless
(
$group_by
{
$order_by_property
}) {
Carp::croak(
"Property '$order_by_property' in the -order_by list must appear in the -group_by list for BoolExpr $rule"
);
}
}
}
if
(
$cache_size_highwater
and
$all_objects_cache_size
>
$cache_size_highwater
) {
$self
->prune_object_cache();
}
if
(
$rule_template
->isa(
"UR::BoolExpr::Template::Or"
)) {
return
$self
->_get_objects_for_class_and_or_rule(
$class
,
$rule
,
$load
,
$return_closure
);
}
my
$this_get_serial
=
$GET_COUNTER
++;
my
$meta
=
$class
->__meta__();
my
$subclassify_by
=
$meta
->subclassify_by;
if
(
$subclassify_by
and !
$meta
->is_abstract
and !
$rule
->template->group_by
and !
$rule
->specifies_value_for(
$subclassify_by
)
) {
$rule
=
$rule
->add_filter(
$subclassify_by
=>
$class
);
}
my
$ds
;
if
(!
defined
(
$load
) or
$load
) {
(
$ds
) =
$self
->resolve_data_sources_for_class_meta_and_rule(
$meta
,
$rule
);
if
(!
$ds
or
$class
=~ m/::Ghost$/) {
$load
= 0;
}
}
my
$cached
;
my
$no_hard_refs_rule
=
$rule
->flatten_hard_refs;
my
$normalized_rule
=
$no_hard_refs_rule
->normalize;
my
$is_monitor_query
=
$self
->monitor_query;
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,Carp::shortmess(
"QUERY: Query start for rule $normalized_rule"
))
if
(
$is_monitor_query
);
unless
(
defined
$load
) {
my
(
$cache_is_complete
,
$cached
) =
$self
->_cache_is_complete_for_class_and_normalized_rule(
$class
,
$normalized_rule
);
$load
= (
$cache_is_complete
? 0 : 1);
}
if
(
$ds
and
$load
and
$rule_template
->order_by) {
my
$qp
=
$ds
->_resolve_query_plan(
$rule_template
);
if
(
$qp
->order_by_non_column_data) {
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,
"QUERY: Doing an unordered query on the datasource because one of the order_by properties of the rule is not expressable by the data source"
)
if
(
$is_monitor_query
);
$self
->get_objects_for_class_and_rule(
$class
,
$rule
->remove_filter(
'-order'
)->remove_filter(
'-order_by'
), 1);
$load
= 0;
}
}
my
$normalized_rule_template
=
$normalized_rule
->template;
if
(!
$load
and !
$return_closure
) {
my
@c
=
$self
->_get_objects_for_class_and_rule_from_cache(
$class
,
$normalized_rule
);
my
$obj_count
=
scalar
(
@c
);
foreach
(
@c
) {
unless
(
exists
$_
->{
'__get_serial'
}) {
my
$class
=
ref
$_
;
my
$id
=
$_
->id;
my
$ref
=
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
};
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
} =
$ref
;
}
$_
->{
'__get_serial'
} =
$this_get_serial
;
}
if
(
$is_monitor_query
) {
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,
"QUERY: matched $obj_count cached objects (no loading)"
);
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,
"QUERY: Query complete after returning $obj_count object(s) for rule $rule"
);
$self
->_log_done_elapsed_time_for_rule(
$normalized_rule
);
}
if
(
defined
(
$normalized_rule_template
->limit) ||
defined
(
$normalized_rule_template
->offset)) {
$self
->_prune_obj_list_for_limit_and_offset(\
@c
,
$normalized_rule_template
);
}
return
@c
if
wantarray
;
return
unless
defined
wantarray
;
Carp::confess(
"multiple objects found for a call in scalar context!"
. Data::Dumper::Dumper(\
@c
))
if
@c
> 1;
return
$c
[0];
}
my
$object_sorter
=
$normalized_rule_template
->sorter();
if
(
$cached
) {
@$cached
=
sort
$object_sorter
@$cached
;
}
else
{
$cached
= [
sort
$object_sorter
$self
->_get_objects_for_class_and_rule_from_cache(
$class
,
$normalized_rule
) ];
}
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,
"QUERY: matched "
.
scalar
(
@$cached
).
" cached objects"
)
if
(
$is_monitor_query
);
foreach
(
@$cached
) {
unless
(
exists
$_
->{
'__get_serial'
}) {
my
$class
=
ref
$_
;
my
$id
=
$_
->id;
my
$ref
=
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
};
$UR::Context::all_objects_loaded
->{
$class
}->{
$id
} =
$ref
;
}
$_
->{
'__get_serial'
} =
$this_get_serial
;
}
my
$loading_iterator
;
if
(
$load
) {
$self
->_log_query_for_rule(
$class
,
$normalized_rule
,
"QUERY: importing from underlying context with rule $normalized_rule"
)
if
(
$is_monitor_query
);
$loading_iterator
= UR::Context::LoadingIterator->_create(
$cached
,
$self
,
$normalized_rule
,
$ds
,
$this_get_serial
);
}
if
(
$return_closure
) {
if
(
$load
) {
return
$loading_iterator
;
}
else
{
if
(
defined
(
$normalized_rule_template
->limit) ||
defined
(
$normalized_rule_template
->offset)) {
$self
->_prune_obj_list_for_limit_and_offset(
$cached
,
$normalized_rule_template
);
}
return
sub
{
return
shift
@$cached
};
}
}
else
{
my
@results
;
if
(
$loading_iterator
) {
my
$found
;
while
(
defined
(
$found
=
$loading_iterator
->(1))) {
push
@results
,
$found
;
}
}
else
{
if
(
defined
(
$normalized_rule_template
->limit) ||
defined
(
$normalized_rule_template
->offset)) {
$self
->_prune_obj_list_for_limit_and_offset(
$cached
,
$normalized_rule_template
);
}
@results
=
@$cached
;
}
return
unless
defined
wantarray
;
return
@results
if
wantarray
;
if
(
@results
> 1) {
$self
->_exception_for_multi_objects_in_scalar_context(
$rule
,\
@results
);
}
return
$results
[0];
}
}
sub
_exception_for_multi_objects_in_scalar_context {
my
(
$self
,
$rule
,
$resultsref
) =
@_
;
my
$message
=
sprintf
(
"Multiple results unexpected for query.\n\tClass %s\n\trule params: %s\n\tGot %d results"
,
$rule
->subject_class_name,
join
(
','
,
$rule
->params_list),
scalar
(
@$resultsref
));
my
$lastidx
=
$#$resultsref
;
if
(
@$resultsref
> 10) {
$message
.=
"; the first 10 are"
;
$lastidx
= 9;
}
Carp::confess(
$message
.
":\n"
. Data::Dumper::Dumper([
@$resultsref
[0..
$lastidx
]]));
}
sub
_prune_obj_list_for_limit_and_offset {
my
(
$self
,
$obj_list
,
$tmpl
) =
@_
;
my
$limit
=
defined
(
$tmpl
->limit) ?
$tmpl
->limit :
$#$obj_list
;
my
$offset
=
$tmpl
->offset || 0;
if
(
$offset
>
@$obj_list
) {
Carp::carp(
'-offset is larger than the result list'
);
@$obj_list
= ();
}
else
{
@$obj_list
=
splice
(
@$obj_list
,
$offset
,
$limit
);
}
}
sub
__merge_db_data_with_existing_object {
my
(
$self
,
$class_name
,
$existing_object
,
$pending_db_object_data
,
$property_names
) =
@_
;
unless
(
defined
$pending_db_object_data
) {
if
(
defined
(
$existing_object
)
and
$self
->object_exists_in_underlying_context(
$existing_object
)
and
$existing_object
->__changes__
) {
my
$id
=
$existing_object
->id;
Carp::croak(
"$class_name ID '$id' previously existed in an underlying context, has since been deleted from that context, and the cached object now has unsavable changes.\nDump: "
.Data::Dumper::Dumper(
$existing_object
).
"\n"
);
}
else
{
UR::Context::LoadingIterator->_remove_object_from_other_loading_iterators(
$existing_object
);
$existing_object
->__signal_change__(
'delete'
);
$self
->_abandon_object(
$existing_object
);
return
$existing_object
;
}
}
my
$expected_db_data
;
if
(
exists
$existing_object
->{
'db_saved_uncommitted'
}) {
$expected_db_data
=
$existing_object
->{
'db_saved_uncommitted'
};
}
elsif
(
exists
$existing_object
->{
'db_committed'
}) {
$expected_db_data
=
$existing_object
->{
'db_committed'
};
}
else
{
my
$id
=
$existing_object
->id;
Carp::croak(
"$class_name ID '$id' has just been loaded, but it exists in the application as a new unsaved object!\nDump: "
. Data::Dumper::Dumper(
$existing_object
) .
"\n"
);
}
my
$different
= 0;
my
$conflict
=
undef
;
foreach
my
$property
(
@$property_names
) {
no
warnings
'uninitialized'
;
next
unless
(
exists
$existing_object
->{
$property
});
my
$object_value
=
$existing_object
->{
$property
};
my
$db_value
=
$pending_db_object_data
->{
$property
};
my
$expected_db_value
=
$expected_db_data
->{
$property
};
if
(
$object_value
ne
$expected_db_value
) {
$different
++;
}
if
(
$object_value
eq
$db_value
or
(
$object_value
eq
$expected_db_value
)
or
(
$db_value
eq
$expected_db_value
)
) {
next
;
}
else
{
$conflict
=
$property
;
last
;
}
}
if
(
defined
$conflict
) {
my
%old_dbc
=
%$expected_db_data
;
@$expected_db_data
{
@$property_names
} =
@$pending_db_object_data
{
@$property_names
};
my
$old_value
=
defined
(
$old_dbc
{
$conflict
})
?
"'"
.
$old_dbc
{
$conflict
} .
"'"
:
'(undef)'
;
my
$new_db_value
=
defined
(
$pending_db_object_data
->{
$conflict
})
?
"'"
.
$pending_db_object_data
->{
$conflict
} .
"'"
:
'(undef)'
;
my
$new_obj_value
=
defined
(
$existing_object
->{
$conflict
})
?
"'"
.
$existing_object
->{
$conflict
} .
"'"
:
'(undef)'
;
my
$obj_id
=
$existing_object
->id;
Carp::croak(
"\nA change has occurred in the database for $class_name property '$conflict' on object ID $obj_id from $old_value to $new_db_value.\n"
.
"At the same time, this application has made a change to that value to $new_obj_value.\n\n"
.
"The application should lock data which it will update and might be updated by other applications."
);
}
%$expected_db_data
= (
%$expected_db_data
,
%$pending_db_object_data
);
if
(!
$different
) {
local
$UR::Context::Transaction::log_all_changes
= 0;
foreach
my
$property
(
@$property_names
) {
no
warnings
'uninitialized'
;
next
if
(
$existing_object
->{
$property
} eq
$pending_db_object_data
->{
$property
});
$existing_object
->
$property
(
$pending_db_object_data
->{
$property
});
}
}
my
@change_count
=
$existing_object
->__changes__;
$existing_object
->{
'_change_count'
} =
scalar
(
@change_count
);
return
$different
;
}
sub
_get_objects_for_class_and_sql {
my
(
$self
,
$class
,
$sql
) =
@_
;
my
$meta
=
$class
->__meta__;
my
$ds
=
$self
->resolve_data_sources_for_class_meta_and_rule(
$meta
,UR::BoolExpr->resolve(
$class
));
my
$id_list
=
$ds
->_resolve_ids_from_class_name_and_sql(
$class
,
$sql
);
return
unless
(
defined
(
$id_list
) and
@$id_list
);
my
$rule
= UR::BoolExpr->resolve_normalized(
$class
,
id
=>
$id_list
);
return
$self
->get_objects_for_class_and_rule(
$class
,
$rule
);
}
sub
_cache_is_complete_for_class_and_normalized_rule {
my
(
$self
,
$class
,
$normalized_rule
) =
@_
;
my
(
$id
,
$params
,
@objects
,
$cache_is_complete
);
$params
=
$normalized_rule
->legacy_params_hash;
$id
=
$params
->{id};
my
$id_only
=
$params
->{_id_only};
$id_only
=
undef
if
ref
(
$id
) and
ref
(
$id
) eq
'HASH'
;
if
(
$id_only
) {
if
(
ref
$id
) {
@objects
=
grep
{
$_
}
map
{
@$_
{
@$id
} }
map
{
$all_objects_loaded
->{
$_
} }
(
$class
,
$class
->__meta__->subclasses_loaded);
if
(
@objects
==
@$id
) {
$cache_is_complete
= 1;
}
else
{
@objects
= ();
}
}
else
{
no
warnings;
if
(
exists
$all_objects_loaded
->{
$class
}->{
$id
}) {
$cache_is_complete
= 1;
@objects
=
grep
{
$_
}
$all_objects_loaded
->{
$class
}->{
$id
};
}
elsif
(not
$class
->isa(
"UR::Value"
)) {
@objects
=
grep
{
$_
}
map
{
$all_objects_loaded
->{
$_
}->{
$id
} }
$class
->__meta__->subclasses_loaded;
if
(
@objects
) {
$cache_is_complete
= 1;
}
}
}
}
elsif
(
$params
->{_unique}) {
@objects
=
$self
->_get_objects_for_class_and_rule_from_cache(
$class
,
$normalized_rule
);
if
(
@objects
) {
$cache_is_complete
= 1;
}
}
if
(
$cache_is_complete
) {
return
wantarray
? (1, \
@objects
) : ();
}
my
$template_id
=
$normalized_rule
->template_id;
my
$rule_id
=
$normalized_rule
->id;
my
$loading_is_in_progress_on_another_iterator
=
grep
{
$_
->is_loading_in_progress_for_boolexpr(
$normalized_rule
) }
UR::Context::ObjectFabricator->all_object_fabricators;
return
0
if
$loading_is_in_progress_on_another_iterator
;
my
$loading_was_done_before_with_these_params
= (
(
exists
(
$UR::Context::all_params_loaded
->{
$template_id
})
and
exists
(
$UR::Context::all_params_loaded
->{
$template_id
}->{
$rule_id
})
)
||
(
$self
->_loading_was_done_before_with_a_superset_of_this_rule(
$normalized_rule
))
);
my
$object_is_loaded_or_non_existent
=
$loading_was_done_before_with_these_params
||
$class
->all_objects_are_loaded;
if
(
$object_is_loaded_or_non_existent
) {
return
1;
}
else
{
return
;
}
}
sub
all_objects_loaded {
my
$self
=
shift
;
my
$class
=
$_
[0];
return
(
grep
{
$_
}
map
{
values
%{
$UR::Context::all_objects_loaded
->{
$_
} } }
$class
,
$class
->__meta__->subclasses_loaded
);
}
sub
all_objects_loaded_unsubclassed {
my
$self
=
shift
;
my
$class
=
$_
[0];
return
(
grep
{
$_
}
values
%{
$UR::Context::all_objects_loaded
->{
$class
} } );
}
sub
_get_objects_for_class_and_rule_from_cache {
my
(
$self
,
$class
,
$rule
) =
@_
;
my
(
$template
,
@values
) =
$rule
->template_and_values;
my
$strategy
=
$rule
->{_context_query_strategy};
unless
(
$strategy
) {
if
(
$rule
->template->group_by) {
$strategy
=
$rule
->{_context_query_strategy} =
"set intersection"
;
}
elsif
(
$rule
->num_values == 0) {
$strategy
=
$rule
->{_context_query_strategy} =
"all"
;
}
elsif
(
$rule
->is_id_only) {
$strategy
=
$rule
->{_context_query_strategy} =
"id"
;
}
else
{
$strategy
=
$rule
->{_context_query_strategy} =
"index"
;
}
}
my
@results
=
eval
{
if
(
$strategy
eq
"all"
) {
return
$self
->all_objects_loaded(
$class
);
}
elsif
(
$strategy
eq
"id"
) {
my
$id
=
$rule
->value_for_id();
unless
(
defined
$id
) {
$id
=
$rule
->value_for_id();
}
my
@matches
;
if
(
ref
(
$id
) eq
'ARRAY'
) {
@matches
=
grep
{
$_
}
map
{
@$_
{
@$id
} }
map
{
$all_objects_loaded
->{
$_
} } (
$class
);
return
@matches
if
@matches
==
@$id
;
}
else
{
if
(not
defined
$id
) {
Carp::cluck(
"\n\n**** Undefined id passed as params for query on $class"
);
$id
||=
''
;
}
my
$match
;
if
(!
$UR::Object::Type::bootstrapping
and
$class
eq
'UR::Object::Type'
) {
my
$meta_class_name
=
$id
.
'::Type'
;
$match
=
$all_objects_loaded
->{
$meta_class_name
}->{
$id
}
||
$all_objects_loaded
->{
'UR::Object::Type'
}->{
$id
};
if
(
$match
) {
return
$match
;
}
else
{
return
;
}
}
$match
=
$all_objects_loaded
->{
$class
}->{
$id
};
return
$match
if
$match
;
}
my
@subclasses_loaded
=
$class
->__meta__->subclasses_loaded;
return
@matches
unless
@subclasses_loaded
;
if
(
ref
(
$id
) eq
'ARRAY'
) {
push
@matches
,
grep
{
$_
}
map
{
@$_
{
@$id
} }
map
{
$all_objects_loaded
->{
$_
} }
@subclasses_loaded
;
}
else
{
for
(
@subclasses_loaded
) {
my
$match
=
$all_objects_loaded
->{
$_
}->{
$id
};
return
$match
if
$match
;
}
}
return
@matches
;
}
elsif
(
$strategy
eq
"index"
) {
my
$class_meta
=
$rule
->subject_class_name->__meta__;
my
%params
=
$rule
->params_list;
my
$should_evaluate_later
;
for
my
$key
(
keys
%params
) {
if
(
substr
(
$key
,0,1) eq
'-'
or
substr
(
$key
,0,1) eq
'_'
) {
delete
$params
{
$key
};
}
elsif
(
$key
=~ /^\w*\./) {
$should_evaluate_later
= 1;
delete
$params
{
$key
};
}
else
{
my
$prop_meta
=
$class_meta
->property_meta_for_name(
$key
);
if
(
$prop_meta
&& (
$prop_meta
->is_many or
$prop_meta
->is_delegated)) {
$should_evaluate_later
= 1;
delete
$params
{
$key
};
}
}
}
my
@properties
=
sort
keys
%params
;
unless
(
@properties
) {
return
grep
{
$rule
->evaluate(
$_
) }
$self
->all_objects_loaded(
$class
);
}
my
@values
=
map
{
$params
{
$_
} }
@properties
;
unless
(
@properties
==
@values
) {
Carp::confess();
}
my
$pstring
=
join
(
","
,
@properties
);
my
$index_id
= UR::Object::Index->__meta__->resolve_composite_id_from_ordered_values(
$class
,
$pstring
);
my
$index
=
$all_objects_loaded
->{
'UR::Object::Index'
}{
$index_id
};
$index
||= UR::Object::Index->create(
id
=>
$index_id
,
indexed_class_name
=>
$class
,
indexed_property_string
=>
$pstring
);
if
(
$UR::Debug::verify_indexes
) {
my
@matches
=
$index
->get_objects_matching(
@values
);
@matches
=
sort
@matches
;
my
@matches2
=
sort
grep
{
$rule
->evaluate(
$_
) }
$self
->all_objects_loaded(
$class
);
unless
(
"@matches"
eq
"@matches2"
) {
print
"@matches\n"
;
print
"@matches2\n"
;
my
@matches3
=
$index
->get_objects_matching(
@values
);
my
@matches4
=
$index
->get_objects_matching(
@values
);
return
@matches2
;
}
return
@matches
;
}
if
(
$should_evaluate_later
) {
return
grep
{
$rule
->evaluate(
$_
) }
$index
->get_objects_matching(
@values
);
}
else
{
return
$index
->get_objects_matching(
@values
);
}
}
elsif
(
$strategy
eq
'set intersection'
) {
my
$template
=
$rule
->template;
my
$group_by
=
$template
->group_by;
my
$rule_no_group
=
$rule
->remove_filter(
'-group_by'
);
$rule_no_group
=
$rule_no_group
->remove_filter(
'-order_by'
);
my
@objects_in_set
=
$self
->_get_objects_for_class_and_rule_from_cache(
$class
,
$rule_no_group
);
my
@sets_from_grouped_objects
= _group_objects(
$rule_no_group
->template,\
@values
,
$group_by
,\
@objects_in_set
);
my
$set_class
=
$class
.
'::Set'
;
my
$expected_template_id
=
$rule
->template->_template_for_grouped_subsets->id;
my
@matches
=
grep
{
my
$bx
= UR::BoolExpr->get(
$_
->id);
my
$bxt
=
$bx
->template;
if
(
$bxt
->id ne
$expected_template_id
) {
();
}
elsif
(not
$bx
->is_subset_of(
$rule_no_group
) ) {
();
}
else
{
(
$_
);
}
}
$self
->all_objects_loaded(
$set_class
);
return
@matches
;
}
else
{
die
"unknown strategy $strategy"
;
}
};
die
$@
if
$@;
if
(
my
$recurse
=
$template
->recursion_desc) {
my
(
$this
,
$prior
) =
@$recurse
;
my
@values
=
grep
{
defined
}
map
{
$_
->
$prior
}
@results
;
if
(
@values
) {
push
@results
,
map
{
$class
->get(
$this
=>
$_
,
-recurse
=>
$recurse
) }
@values
;
}
}
my
$group_by
=
$template
->group_by;
if
(
@results
> 1) {
my
$sorter
;
if
(
$group_by
) {
my
$set_class
=
$template
->subject_class_name .
'::Set'
;
my
$set_template
= UR::BoolExpr::Template->resolve(
$set_class
,
-group_by
=>
$group_by
);
$sorter
=
$set_template
->sorter;
}
else
{
$sorter
=
$template
->sorter;
}
@results
=
sort
$sorter
@results
;
}
return
@results
if
(
wantarray
);
Carp::confess(
"Multiple matches for $class @_!"
)
if
(
@results
> 1);
return
$results
[0];
}
sub
_group_objects {
my
(
$template
,
$values
,
$group_by
,
$objects
) =
@_
;
my
$sub_template
=
$template
->remove_filter(
'-group_by'
);
for
my
$property
(
@$group_by
) {
$sub_template
=
$sub_template
->add_filter(
$property
);
}
my
$set_class
=
$template
->subject_class_name .
'::Set'
;
my
@groups
;
my
%seen
;
for
my
$result
(
@$objects
) {
my
%values_for_group_property
;
foreach
my
$group_property
(
@$group_by
) {
my
@values
=
$result
->
$group_property
;
if
(
@values
) {
$values_for_group_property
{
$group_property
} = \
@values
;
}
else
{
$values_for_group_property
{
$group_property
} = [
undef
];
}
}
my
@combinations
= UR::Util::combinations_of_values(
map
{
$values_for_group_property
{
$_
} }
@$group_by
);
foreach
my
$extra_values
(
@combinations
) {
my
$bx
=
$sub_template
->get_rule_for_values(
@$values
,
@$extra_values
);
next
if
$seen
{
$bx
->id}++;
my
$group
=
$set_class
->get(
$bx
->id);
push
@groups
,
$group
;
}
}
return
@groups
;
}
sub
_loading_was_done_before_with_a_superset_of_this_rule {
my
(
$self
,
$rule
) =
@_
;
my
$template
=
$rule
->template;
if
(
exists
$UR::Context::all_params_loaded
->{
$template
->id}
and
exists
$UR::Context::all_params_loaded
->{
$template
->id}->{
$rule
->id}
) {
return
1;
}
if
(
$template
->subject_class_name->isa(
"UR::Value"
)) {
return
;
}
my
@rule_values
=
$rule
->
values
;
my
@rule_param_names
=
$template
->_property_names;
my
%rule_values
;
for
(
my
$i
= 0;
$i
<
@rule_param_names
;
$i
++) {
$rule_values
{
$rule_param_names
[
$i
] } =
$rule_values
[
$i
];
}
foreach
my
$loaded_template_id
(
keys
%$UR::Context::all_params_loaded
) {
my
$loaded_template
= UR::BoolExpr::Template->get(
$loaded_template_id
);
if
(
$template
->is_subset_of(
$loaded_template
)) {
my
@param_names
=
$loaded_template
->_property_names;
my
@values
=
@rule_values
{
@param_names
};
my
$value_id
;
{
no
warnings
'uninitialized'
;
$value_id
=
join
(
$UR::BoolExpr::Util::record_sep
,
@values
);
}
my
@candidates
=
grep
{
index
(
$_
,
$value_id
) > 0 }
keys
(%{
$UR::Context::all_params_loaded
->{
$loaded_template_id
} });
foreach
my
$loaded_rule_id
(
@candidates
) {
my
$loaded_rule
= UR::BoolExpr->get(
$loaded_rule_id
);
return
1
if
(
$rule
->is_subset_of(
$loaded_rule
));
}
}
}
return
;
}
sub
_forget_loading_was_done_with_template_and_rule {
my
(
$self
,
$template_id
,
$rule_id
) =
@_
;
delete
$all_params_loaded
->{
$template_id
}->{
$rule_id
};
}
sub
_get_all_subsets_of_params {
my
$self
=
shift
;
return
[]
unless
@_
;
my
$first
=
shift
;
my
@rest
=
$self
->_get_all_subsets_of_params(
@_
);
return
@rest
,
map
{ [
$first
,
@$_
] }
@rest
;
}
sub
query_underlying_context {
my
$self
=
shift
;
unless
(
ref
$self
) {
$self
=
$self
->current;
}
if
(
@_
) {
$self
->{
'query_underlying_context'
} =
shift
;
}
return
$self
->{
'query_underlying_context'
};
}
sub
has_changes {
return
shift
->get_current->has_changes(
@_
);
}
sub
commit {
Carp::carp
'UR::Context::commit() called as a function, not a method. Assumming commit on current context'
unless
@_
;
my
$self
=
shift
;
$self
= UR::Context->current()
unless
ref
$self
;
$self
->__signal_change__(
'precommit'
);
unless
(
$self
->_sync_databases) {
$self
->__signal_observers__(
'sync_databases'
, 0);
$self
->__signal_change__(
'commit'
,0);
return
;
}
$self
->__signal_observers__(
'sync_databases'
, 1);
unless
(
$self
->_commit_databases) {
$self
->__signal_change__(
'commit'
,0);
die
"Application failure during commit!"
;
}
$self
->__signal_change__(
'commit'
,1);
$_
->
delete
foreach
UR::Change->get();
foreach
(
$self
->all_objects_loaded(
'UR::Object'
) ) {
delete
$_
->{
'_change_count'
};
}
return
1;
}
sub
rollback {
my
$self
=
shift
;
unless
(
$self
) {
warn
'UR::Context::rollback() called as a function, not a method. Assumming rollback on current context'
;
$self
= UR::Context->current();
}
$self
->__signal_change__(
'prerollback'
);
unless
(
$self
->_reverse_all_changes) {
$self
->__signal_change__(
'rollback'
, 0);
die
"Application failure during reverse_all_changes?!"
;
}
unless
(
$self
->_rollback_databases) {
$self
->__signal_change__(
'rollback'
, 0);
die
"Application failure during rollback!"
;
}
$self
->__signal_change__(
'rollback'
, 1);
return
1;
}
sub
_tmp_self {
my
$self
=
shift
;
if
(
ref
(
$self
)) {
return
(
$self
,
ref
(
$self
));
}
else
{
return
(
$UR::Context::current
,
$self
);
}
}
sub
clear_cache {
my
(
$self
,
$class
) = _tmp_self(
shift
@_
);
my
%args
=
@_
;
my
%local_dont_unload
;
if
(
$args
{
'dont_unload'
}) {
for
my
$class_name
(@{
$args
{
'dont_unload'
}}) {
$local_dont_unload
{
$class_name
} = 1;
for
my
$subclass_name
(
$class_name
->__meta__->subclasses_loaded) {
$local_dont_unload
{
$subclass_name
} = 1;
}
}
}
for
my
$class_name
(UR::Object->__meta__->subclasses_loaded) {
next
if
$class_name
eq
"UR::Command::Param"
;
next
if
$class_name
->isa(
'UR::Singleton'
);
my
$class_obj
=
$class_name
->__meta__;
next
unless
$class_obj
->is_uncachable;
next
if
$class_obj
->is_meta_meta;
next
unless
$class_obj
->is_transactional;
next
if
(
$local_dont_unload
{
$class_name
} ||
grep
{
$class_name
->isa(
$_
) } @{
$args
{
'dont_unload'
}});
next
if
$class_obj
->is_meta;
next
if
not
defined
$class_obj
->data_source;
for
my
$obj
(
$self
->all_objects_loaded_unsubclassed(
$class_name
)) {
my
$obj_type
=
ref
$obj
;
next
if
(
$local_dont_unload
{
$obj_type
} ||
grep
{
$obj_type
->isa(
$_
) } @{
$args
{
'dont_unload'
}});
$obj
->unload;
}
my
@obj
=
grep
{
defined
(
$_
) }
values
%{
$UR::Context::all_objects_loaded
->{
$class_name
} };
if
(
@obj
) {
$class
->warning_message(
"Skipped unload of $class_name objects during clear_cache: "
.
join
(
","
,
map
{
$_
->id }
@obj
)
.
"\n"
);
if
(
my
@changed
=
grep
{
$_
->__changes__ }
@obj
) {
$class
->error_message(
"The following objects have changes:\n"
. Data::Dumper::Dumper(\
@changed
)
.
"The clear_cache method cannot be called with unsaved changes on objects.\n"
.
"Use reverse_all_changes() first to really undo everything, then clear_cache(),"
.
" or call sync_database() and clear_cache() if you want to just lighten memory but keep your changes.\n"
.
"Clearing the cache with active changes will be supported after we're sure all code like this is gone. :)\n"
);
exit
1;
}
}
delete
$UR::Context::all_objects_loaded
->{
$class_name
};
delete
$UR::Context::all_objects_are_loaded
->{
$class_name
};
delete
$UR::Context::all_params_loaded
->{
$class_name
};
}
1;
}
sub
_order_data_sources_for_saving {
my
@data_sources
=
@_
;
my
%can_savepoint
=
map
{
$_
->
id
=>
$_
->can_savepoint }
@data_sources
;
my
%classes
=
map
{
$_
->
id
=>
$_
->class }
@data_sources
;
my
%is_default
=
map
{
$_
->
id
=>
$_
->isa(
'UR::DataSource::Default'
) ? 1 : 0 }
@data_sources
;
return
sort
{
$is_default
{
$a
->id} <=>
$is_default
{
$b
->id}
||
$can_savepoint
{
$a
->id} <=>
$can_savepoint
{
$b
->id}
||
$classes
{
$a
->id} cmp
$classes
{
$b
->id}
}
@data_sources
;
}
our
$IS_SYNCING_DATABASE
= 0;
sub
_sync_databases {
my
$self
=
shift
;
my
%params
=
@_
;
return
1
if
$IS_SYNCING_DATABASE
;
$IS_SYNCING_DATABASE
= 1;
if
(
$App::DB::
{
'sync_database'
}) {
unless
(App::DB->sync_database() ) {
$IS_SYNCING_DATABASE
= 0;
$self
->error_message(App::DB->error_message());
return
;
}
}
$IS_SYNCING_DATABASE
= 0;
my
@o
=
grep
{
ref
(
$_
) eq
'UR::DeletedRef'
}
$self
->all_objects_loaded(
'UR::Object'
);
if
(
@o
) {
print
Data::Dumper::Dumper(\
@o
);
Carp::confess();
}
my
@changed_objects
= (
$self
->all_objects_loaded(
'UR::Object::Ghost'
),
grep
{
$_
->__changes__ }
$self
->all_objects_loaded(
'UR::Object'
)
);
return
1
unless
(
@changed_objects
);
my
@invalid
=
grep
{
$_
->__errors__ }
@changed_objects
;
if
(
@invalid
) {
$self
->display_invalid_data_for_save(\
@invalid
);
goto
PROBLEM_SAVING;
}
my
%ds_objects
;
for
my
$obj
(
@changed_objects
) {
my
$data_source
=
$self
->resolve_data_source_for_object(
$obj
);
next
unless
$data_source
;
my
$data_source_id
=
$data_source
->id;
$ds_objects
{
$data_source_id
} ||= {
'ds_obj'
=>
$data_source
,
'changed_objects'
=> []};
push
@{
$ds_objects
{
$data_source_id
}->{
'changed_objects'
} },
$obj
;
}
my
@ds_in_order
=
map
{
$_
->id }
_order_data_sources_for_saving(
map
{
$_
->{ds_obj} }
values
(
%ds_objects
));
my
@done
;
my
$rollback_on_non_savepoint_handle
;
for
my
$data_source_id
(
@ds_in_order
) {
my
$obj_list
=
$ds_objects
{
$data_source_id
}->{
'changed_objects'
};
my
$data_source
=
$ds_objects
{
$data_source_id
}->{
'ds_obj'
};
my
$result
=
$data_source
->_sync_database(
%params
,
changed_objects
=>
$obj_list
,
);
if
(
$result
) {
push
@done
,
$data_source
;
next
;
}
else
{
$self
->error_message(
"Failed to sync data source: $data_source_id: "
.
$data_source
->error_message
);
for
my
$prev_data_source
(
@done
) {
$prev_data_source
->_reverse_sync_database;
}
goto
PROBLEM_SAVING;
}
}
return
1;
PROBLEM_SAVING:
if
(
$App::DB::
{
'rollback'
}) {
App::DB->rollback();
}
return
;
}
sub
display_invalid_data_for_save {
my
$self
=
shift
;
my
@objects_with_errors
= @{
shift
@_
};
$self
->error_message(
'Invalid data for save!'
);
for
my
$obj
(
@objects_with_errors
) {
no
warnings;
my
$identifier
=
eval
{
$obj
->__display_name__ } ||
$obj
->id;
my
$msg
=
$obj
->class .
" identified by "
.
$identifier
.
" has problems on\n"
;
my
@problems
=
$obj
->__errors__;
foreach
my
$error
(
@problems
) {
$msg
.=
$error
->__display_name__ .
"\n"
;
}
$msg
.=
" Current state:\n"
;
my
$datadumper
= Data::Dumper::Dumper(
$obj
);
my
$nr_of_lines
=
$datadumper
=~
tr
/\n//;
if
(
$nr_of_lines
> 40) {
$datadumper
=~ m/^((?:.*\n){15})/;
$msg
.= $1;
$datadumper
=~ m/((?:.*(?:\n|$)){3})$/;
$msg
.=
"[...]\n$1\n"
;
}
else
{
$msg
.=
$datadumper
;
}
$self
->error_message(
$msg
);
}
return
1;
}
sub
_reverse_all_changes {
my
$self
=
shift
;
my
$class
;
if
(
ref
(
$self
)) {
$class
=
ref
(
$self
);
}
else
{
$class
=
$self
;
$self
=
$UR::Context::current
;
}
@UR::Context::Transaction::open_transaction_stack
= ();
@UR::Context::Transaction::change_log
= ();
$UR::Context::Transaction::log_all_changes
= 0;
$UR::Context::current
=
$UR::Context::process
;
my
@objects
=
map
{
$self
->all_objects_loaded_unsubclassed(
$_
) }
grep
{
$_
->__meta__->is_transactional }
grep
{ !
$_
->isa(
'UR::Value'
) }
sort
UR::Object->__meta__->subclasses_loaded();
for
my
$object
(
@objects
) {
$object
->__rollback__();
}
return
1;
}
our
$IS_COMMITTING_DATABASE
= 0;
sub
_commit_databases {
my
$class
=
shift
;
return
1
if
$IS_COMMITTING_DATABASE
;
$IS_COMMITTING_DATABASE
= 1;
if
(
$App::DB::
{
'commit'
}) {
unless
(App::DB->commit() ) {
$IS_COMMITTING_DATABASE
= 0;
$class
->error_message(App::DB->error_message());
return
;
}
}
$IS_COMMITTING_DATABASE
= 0;
my
@ds_in_order
= _order_data_sources_for_saving(
$UR::Context::current
->all_objects_loaded(
'UR::DataSource'
));
my
@committed
;
foreach
my
$ds
(
@ds_in_order
) {
if
(
$ds
->commit) {
push
@committed
,
$ds
;
}
else
{
my
$message
=
'Data source '
.
$ds
->get_name .
' failed to commit: '
.
join
(
"\n\t"
,
$ds
->error_messages);
if
(
@committed
) {
$message
.=
"\nThese data sources were successfully committed, resulting in a FRAGMENTED DISTRIBUTED TRANSACTION: "
.
join
(
', '
,
map
{
$_
->get_name }
@committed
);
}
Carp::croak(
$message
);
}
}
return
1;
}
our
$IS_ROLLINGBACK_DATABASE
= 0;
sub
_rollback_databases {
my
$class
=
shift
;
return
1
if
$IS_ROLLINGBACK_DATABASE
;
$IS_ROLLINGBACK_DATABASE
= 1;
if
(
$App::DB::
{
'rollback'
}) {
unless
(App::DB->rollback()) {
$IS_ROLLINGBACK_DATABASE
= 0;
$class
->error_message(App::DB->error_message());
return
;
}
}
$IS_ROLLINGBACK_DATABASE
= 0;
$class
->_for_each_data_source(
"rollback"
)
or
die
"FAILED TO ROLLBACK!: "
.
$class
->error_message;
return
1;
}
sub
_disconnect_databases {
my
$class
=
shift
;
$class
->_for_each_data_source(
"disconnect"
);
return
1;
}
sub
_for_each_data_source {
my
(
$class
,
$method
) =
@_
;
my
@ds
=
$UR::Context::current
->all_objects_loaded(
'UR::DataSource'
);
foreach
my
$ds
(
@ds
) {
unless
(
$ds
->
$method
) {
$class
->error_message(
"$method failed on DataSource "
,
$ds
->get_name);
return
;
}
}
return
1;
}
sub
_get_committed_property_value {
my
$class
=
shift
;
my
$object
=
shift
;
my
$property_name
=
shift
;
if
(
$object
->{
'db_committed'
}) {
return
$object
->{
'db_committed'
}->{
$property_name
};
}
elsif
(
$object
->{
'db_saved_uncommitted'
}) {
return
$object
->{
'db_saved_uncommitted'
}->{
$property_name
};
}
else
{
return
;
}
}
sub
_dump_change_snapshot {
my
$class
=
shift
;
my
%params
=
@_
;
my
@c
=
grep
{
$_
->__changes__ }
$UR::Context::current
->all_objects_loaded(
'UR::Object'
);
my
$fh
;
if
(
my
$filename
=
$params
{filename})
{
$fh
= IO::File->new(
">$filename"
);
unless
(
$fh
)
{
$class
->error_message(
"Failed to open file $filename: $!"
);
return
;
}
}
else
{
$fh
=
"STDOUT"
;
}
$fh
->
print
(YAML::Dump(\
@c
));
$fh
->
close
;
}
sub
reload {
my
$self
=
shift
;
my
$class
=
shift
;
if
(
ref
$class
) {
if
(
@_
) {
Carp::confess(
"load() on an instance with parameters is not supported"
);
return
;
}
@_
= (
'id'
,
$class
->id());
$class
=
ref
$class
;
}
my
(
$rule
,
@extra
) = UR::BoolExpr->resolve_normalized(
$class
,
@_
);
if
(
@extra
) {
if
(
scalar
@extra
== 2 and (
$extra
[0] eq
"sql"
or
$extra
[0] eq
'sql in'
)) {
return
$UR::Context::current
->_get_objects_for_class_and_sql(
$class
,
$extra
[1]);
}
else
{
die
"Odd parameters passed directly to $class load(): @extra.\n"
.
"Processable params were: "
. Data::Dumper::Dumper({
$rule
->params_list });
}
}
return
$UR::Context::current
->get_objects_for_class_and_rule(
$class
,
$rule
,1);
}
1;
Hide Show 736 lines of Pod