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

package UR::DataSource;
use strict;
use warnings;

require UR;
our $VERSION = "0.43"; # UR $VERSION;
use Sys::Hostname;

{
    no warnings 'once';
    *namespace = \&get_namespace;
}

UR::Object::Type->define(
    class_name => 'UR::DataSource',
    is_abstract => 1,
    doc => 'A logical database, independent of prod/dev/testing considerations or login details.',
    has => [
        namespace => { calculate_from => ['id'] },
        is_connected => { is => 'Boolean', default_value => 0, is_optional => 1, is_transient => 1 },
        get_default_handle => {
            is_calculated => 1,
            is_constant   => 1,
            doc => 'Underlying handle for this datasource',
            calculate => '$self->create_default_handle_wrapper',
        },
    ],
    valid_signals => ['precreate_handle', 'create_handle', 'predisconnect_handle', 'disconnect_handle' ],
);

our @CARP_NOT = qw(UR::Context UR::DataSource::QueryPlan);

sub define { shift->__define__(@_) }

sub get_namespace {
    my $class = shift->class;
    return substr($class,0,index($class,"::DataSource"));
}

sub get_name {
    my $class = shift->class;
    return lc(substr($class,index($class,"::DataSource")+14));
}

# The default used to be to force table/column/constraint/etc names to
# upper case when storing them in the MetaDB, and in the column_name
# metadata for properties.  The new behavior is to just use whatever the
# database supplies us when interrogating the data dictionary.
# For datasources/clases that still need the old behavior, override this
# to make the column_name metadata for properties forced to upper-case
sub table_and_column_names_are_upper_case { 0; }


# Basic, dumb data sources do not support joins within a single
# query.  Instead the Context logic can perform a cross datasource
# join within irs own code
sub does_support_joins { 0; }

# Most datasources do not support recursive queries
# Oracle and Postgres do, but in different ways
# For data sources without support, it'll have to do multiple queries
# to get all the data
sub does_support_recursive_queries { ''; }


{
    no warnings 'once';
    *create_dbh = \&create_default_handle_wrapper;
}

sub create_default_handle_wrapper {
    my $self = UR::Util::object(shift);

    $self->__signal_observers__('precreate_handle');
    my $h = $self->create_default_handle;
    $self->__signal_observers__('create_handle', $h);

    # Hack - This is to avoid infinite recursion in the case where the
    # handle initializers below try to get the hadle by calling $ds->get_default_handle.
    # The cached/calculated accessor code will look in this hash key and
    # return the handle instead of recursing back into the handle creation, and
    # back to here
    $self->{get_default_handle} = $h;

    # Backward compatability for older code that still uses _init_created_dbh
    if ($self->can('_init_created_dbh')) {
        $self->_init_created_dbh($h);
    } else {
        $self->init_created_handle($h);
    }

    return $h;
}

# basic, dumb datasources do not have a handle
sub create_default_handle { undef }
sub disconnect { }

# derived classes can implement this to do extra initialization after the
# handle is created
sub init_created_handle { 1;  }

# Peek into the object and see if there's anything in 'get_default_handle' without actually
# creating a handle
*has_default_dbh = \&has_default_handle;
sub has_default_handle {
    my $self = UR::Util::object(shift);
    return exists($self->{get_default_handle});
}

*disconnect_default_dbh = \&disconnect_default_handle;
sub disconnect_default_handle {
    my $self = shift;

    if ($self->has_default_handle) {
        $self->__signal_observers__('predisconnect_handle');
        $self->disconnect();
        $self->__signal_observers__('disconnect_handle');
    }
    1;
}

our $use_dummy_autogenerated_ids;
*use_dummy_autogenerated_ids = \$ENV{UR_USE_DUMMY_AUTOGENERATED_IDS};
sub use_dummy_autogenerated_ids {
    # This allows the saved SQL from sync database to be comparable across executions.
    # It also 
    my $class = shift;
    if (@_) {
        ($use_dummy_autogenerated_ids) = @_;
    }
    $use_dummy_autogenerated_ids ||= 0;  # Replace undef with 0
    return $use_dummy_autogenerated_ids;
}

our $last_dummy_autogenerated_id;
sub next_dummy_autogenerated_id {   
    unless($last_dummy_autogenerated_id) {
        my $hostname = hostname();
        $hostname =~ /(\d+)/;
        my $id = $1 ? $1 : 1;
        $last_dummy_autogenerated_id = ($id * -10_000_000) - ($$ * 1_000);
    }

    #limit id to fit within 11 characters
    ($last_dummy_autogenerated_id) = $last_dummy_autogenerated_id =~ m/(-\d{1,10})/;

    return --$last_dummy_autogenerated_id;
}

sub autogenerate_new_object_id_for_class_name_and_rule {
    my $ds = shift;

    if (ref $ds) {
        $ds = ref($ds) . " ID " . $ds->id;
    }

    # Maybe we could use next_dummy_autogenerated_id instead?
    die "Data source $ds did not implement autogenerate_new_object_id_for_class_name_and_rule()";
}

# UR::Context needs to know if a data source supports savepoints
sub can_savepoint {
    my $class = ref($_[0]);
    die "Class $class didn't supply can_savepoint()";
}

sub set_savepoint {
    my $class = ref($_[0]);
    die "Class $class didn't supply set_savepoint, but can_savepoint is true";
}

sub rollback_to_savepoint {
    my $class = ref($_[0]);
    die "Class $class didn't supply rollback_to_savepoint, but can_savepoint is true";
}


sub _get_class_data_for_loading {
    my ($self, $class_meta) = @_;
    my $class_data = $class_meta->{loading_data_cache};
    unless ($class_data) {
        $class_data = $self->_generate_class_data_for_loading($class_meta);
    }
    return $class_data;
}
    
sub _resolve_query_plan {
    my ($self, $rule_template) = @_;
    my $qp = UR::DataSource::QueryPlan->get(
        rule_template => $rule_template,
        data_source => $self,
    );
    $qp->_init() unless $qp->_is_initialized;
    return $qp;
}

# Child classes can override this to return a different datasource
# depending on the rule passed in
sub resolve_data_sources_for_rule {
    return $_[0];
}
    
sub _generate_class_data_for_loading {
    my ($self, $class_meta) = @_;

    my $class_name = $class_meta->class_name;
    my $ghost_class = $class_name->ghost_class;

    my @all_id_property_names = $class_meta->all_id_property_names();
    my @id_properties = $class_meta->id_property_names;    
    my $id_property_sorter = $class_meta->id_property_sorter;    
    my @class_hierarchy = ($class_meta->class_name,$class_meta->ancestry_class_names);

    my @parent_class_objects = $class_meta->ancestry_class_metas;
    my $sub_classification_method_name;
    my ($sub_classification_meta_class_name, $subclassify_by);
    
    my @all_properties;
    my $first_table_name;
    for my $co ( $class_meta, @parent_class_objects ) {
        my $table_name = $co->table_name || '__default__';
        
        $first_table_name ||= $table_name;
        $sub_classification_method_name ||= $co->sub_classification_method_name;
        $sub_classification_meta_class_name ||= $co->sub_classification_meta_class_name;
        $subclassify_by   ||= $co->subclassify_by;
        
        my $sort_sub = sub ($$) { return $_[0]->property_name cmp $_[1]->property_name };
        push @all_properties, map { [$co, $_, $table_name, 0]} sort $sort_sub UR::Object::Property->get(class_name => $co->class_name);
    }

    my $sub_typing_property = $class_meta->subclassify_by;

    my $class_table_name = $class_meta->table_name;

    my $class_data = {
        class_name                          => $class_name,
        ghost_class                         => $class_name->ghost_class,
        
        parent_class_objects                => [$class_meta->ancestry_class_metas], ##
        sub_classification_method_name      => $sub_classification_method_name,
        sub_classification_meta_class_name  => $sub_classification_meta_class_name,
        subclassify_by    => $subclassify_by,
        
        all_properties                      => \@all_properties,
        all_id_property_names               => [$class_meta->all_id_property_names()],
        id_properties                       => [$class_meta->id_property_names],    
        id_property_sorter                  => $class_meta->id_property_sorter,    
        
        sub_typing_property                 => $sub_typing_property,
        
        # these seem like they go in the RDBMS subclass, but for now the 
        # "table" concept is stretched to mean any valid structure identifier 
        # within the datasource.
        first_table_name                    => $first_table_name,
        class_table_name                    => $class_table_name,
    };
    
    return $class_data;
}

sub _generate_loading_templates_arrayref {
    # Each entry represents a table alias in the query.
    # This accounts for different tables, or multiple occurrances 
    # of the same table in a join, by grouping by alias instead of
    # table.
    
    my $class = shift;
    my $db_cols = shift;
    my $obj_joins = shift;
    my $bxt = shift;

    use strict;
    use warnings;

    my %obj_joins_by_source_alias;
    if (0) { # ($obj_joins) {
        my @obj_joins = @$obj_joins;
        while (@obj_joins) {
            my $foreign_alias = shift @obj_joins;
            my $data = shift @obj_joins;
            for my $foreign_property_name (sort keys %$data) {
                next if $foreign_property_name eq '-is_required';
                
                my $source_alias = $data->{$foreign_property_name}{'link_alias'};
                my $detail = $obj_joins_by_source_alias{$source_alias}{$foreign_alias} ||= {};
                # warnings come from the above because we don't have 'link_alias' in filters.

                my $source_property_name = $data->{$foreign_property_name}{'link_property_name'};
                if ($source_property_name) {
                    # join
                    my $links = $detail->{links} ||= [];
                    push @$links, $foreign_property_name, $source_property_name;
                }

                if (exists $data->{value}) {
                    # filter
                    my $operator = $data->{operator};
                    my $value = $data->{value};
                    my $filter = $detail->{filter} ||= [];
                    my $key = $foreign_property_name;
                    $key .= ' ' . $operator if $operator;
                    push @$filter, $key, $value;
                }
            }
        }
    }
    else {
        #Carp::cluck("no obj joins???");
    }

    my %templates;
    my $pos = 0;
    my @templates;
    my %alias_object_num;
    for my $col_data (@$db_cols) {
        my ($class_obj, $prop, $table_alias, $object_num) = @$col_data;
        unless (defined $object_num) {
            die "No object num for loading template data?!";
        }
        #Carp::confess() unless $table_alias;
        my $template = $templates[$object_num];
        unless ($template) {
            $template = {
                object_num => $object_num,
                table_alias => $table_alias,
                data_class_name => $class_obj->class_name,
                final_class_name => $class_obj->class_name,
                property_names => [],                    
                column_positions => [],                    
                id_property_names => undef,
                id_column_positions => [],
                id_resolver => undef, # subref
            };
            $templates[$object_num] = $template;
            $alias_object_num{$table_alias} = $object_num;
        }
        push @{ $template->{property_names} }, $prop->property_name;
        push @{ $template->{column_positions} }, $pos;
        $pos++;
    }

    # remove joins that resulted in no template, such as when it was to a table-less class
    @templates = grep { $_ } @templates;
    
    # Post-process the template objects a bit to get the exact id positions.
    for my $template (@templates) {
        my @id_property_names;
        for my $id_class_name ($template->{data_class_name}, $template->{data_class_name}->inheritance) {
            my $id_class_obj = UR::Object::Type->get(class_name => $id_class_name);
            last if @id_property_names = $id_class_obj->id_property_names;
        }
        $template->{id_property_names} = \@id_property_names;
        
        my @id_column_positions;
        for my $id_property_name (@id_property_names) {
            for my $n (0..$#{ $template->{property_names} }) {
                if ($template->{property_names}[$n] eq $id_property_name) {
                    push @id_column_positions, $template->{column_positions}[$n];
                    last;
                }
            }
        }
        $template->{id_column_positions} = \@id_column_positions;            
        
        if (@id_column_positions == 1) {
            $template->{id_resolver} = sub {
                return $_[0][$id_column_positions[0]];
            }
        }
        elsif (@id_column_positions > 1) {
            my $class_name = $template->{data_class_name};
            $template->{id_resolver} = sub {
                my $self = shift;
                return $class_name->__meta__->resolve_composite_id_from_ordered_values(@$self[@id_column_positions]);
            }                    
        }
        else {
            Carp::croak("Can't determine which columns will hold the ID property data for class "
                        . $template->{data_class_name} . ".  It's ID properties are (" . join(', ', @id_property_names)
                        . ") which do not appear in the class' property list (" . join(', ', @{$template->{'property_names'}}).")");
        }             

        my $source_alias = $template->{table_alias};
        if (0 and my $join_data_for_source_table = $obj_joins_by_source_alias{$source_alias}) {
            # there are joins which come from this entity to other entities
            # as these entities are loaded, remember the individual queries covered by this object returning
            # NOTE: when we join a <> b, we remember that we've loaded all of the b for a when _a_ loads, not b,
            # since it's possible that there ar zero of b, and we don't want to perform the query for b 
            my $source_object_num = $template->{object_num};
            my $source_class_name = $template->{data_class_name};
            my $next_joins = $template->{next_joins} ||= [];
            for my $foreign_alias (keys %$join_data_for_source_table) {
                my $foreign_object_num = $alias_object_num{$foreign_alias};
                Carp::confess("no alias for $foreign_alias?") if not defined $foreign_object_num;
                my $foreign_template = $templates[$foreign_object_num];
                my $foreign_class_name = $foreign_template->{data_class_name};

                my $join_data = $join_data_for_source_table->{$foreign_alias};
                my %links = map { $_ ? @$_ : () } $join_data->{links};
                my %filters = map { $_ ? @$_ : () } $join_data->{filters};
                
                my @keys = sort (keys %links, keys %filters);
                my @value_position_source_property;
                for (my $n = 0; $n < @keys; $n++) {
                    my $key = $keys[$n];
                    if ($links{$key} and $filters{$key}) {
                        Carp::confess("unexpected same key $key in filters and joins");
                    }
                    my $source_property_name = $links{$key};
                    next unless $source_property_name;
                    push @value_position_source_property, $n, $source_property_name; 
                }
                my $bx = $foreign_class_name->define_boolexpr(map { $_ => $filters{$_} } @keys);
                my ($bxt, @values) = $bx->template_and_values();
                push @$next_joins, [ $bxt->id, \@values, \@value_position_source_property ];
            }
        }
    }        

    return \@templates;        
}

sub create_iterator_closure_for_rule_template_and_values {
    my ($self, $rule_template, @values) = @_;
    my $rule = $rule_template->get_rule_for_values(@values);
    return $self->create_iterator_closure_for_rule($rule);
}

sub _reclassify_object_loading_info_for_new_class {
    my $self = shift;
    my $loading_info = shift;
    my $new_class = shift;

    my $new_info;
    %$new_info = %$loading_info;

    foreach my $template_id (keys %$loading_info) {

        my $target_class_rules = $loading_info->{$template_id};
        foreach my $rule_id (keys %$target_class_rules) {
            my $pos = index($rule_id,'/');
            $new_info->{$template_id}->{$new_class . "/" . substr($rule_id,$pos+1)} = 1;
        }
    }

    return $new_info;
}

sub _get_object_loading_info {
    my $self = shift;
    my $obj  = shift;
    my %param_load_hash;
    if ($obj->{'__load'}) {
        while( my($template_id, $rules) = each %{ $obj->{'__load'} } ) {
            foreach my $rule_id ( keys %$rules ) {
                $param_load_hash{$template_id}->{$rule_id} = $UR::Context::all_params_loaded->{$template_id}->{$rule_id};
            }
        }
    }
    return \%param_load_hash;
}


sub _add_object_loading_info {
    my $self = shift;
    my $obj = shift;
    my $param_load_hash = shift;

    while( my($template_id, $rules) = each %$param_load_hash) {
        foreach my $rule_id ( keys %$rules ) {
            $obj->{'__load'}->{$template_id}->{$rule_id} = $rules->{$rule_id};
        }
    }
}


# same as add_object_loading_info, but manipulates the data in $UR::Context::all_params_loaded
sub _record_that_loading_has_occurred {
    my $self = shift;
    my $param_load_hash = shift;

    while( my($template_id, $rules) = each %$param_load_hash) {
        foreach my $rule_id ( keys %$rules ) {
            $UR::Context::all_params_loaded->{$template_id}->{$rule_id} ||=
                $rules->{$rule_id};
        }
    }
}

sub _first_class_in_inheritance_with_a_table {
    # This is called once per subclass and cached in the subclass from then on.
    my $self = shift;
    my $class = shift;
    $class = ref($class) if ref($class);


    unless ($class) {
        Carp::confess("No class?");
    }
    my $class_object = $class->__meta__;
    my $found = "";
    for ($class_object, $class_object->ancestry_class_metas)
    {                
        if ($_->table_name)
        {
            $found = $_->class_name;
            last;
        }
    }
    #eval qq/
    #    package $class;
    #    sub _first_class_in_inheritance_with_a_table { 
    #        return '$found' if \$_[0] eq '$class';
    #        shift->SUPER::_first_class_in_inheritance_with_a_table(\@_);
    #    }
    #/;
    #die "Error setting data in subclass: $@" if $@;
    return $found;
}

sub _class_is_safe_to_rebless_from_parent_class {
    my ($self, $class, $was_loaded_as_this_parent_class) = @_;
    my $fcwt = $self->_first_class_in_inheritance_with_a_table($class);
    unless ($fcwt) {
        Carp::croak("Can't call _class_is_safe_to_rebless_from_parent_class(): Class $class has no parent classes with a table");
    }
    return ($was_loaded_as_this_parent_class->isa($fcwt));
}

sub ur_datasource_class_for_dbi_connect_string {
    my($class, $dsn) = @_;
    my(undef, $driver) = DBI->parse_dsn($dsn);
    $driver
        || Carp::croak("Could not parse DBI driver out of connect string $dsn");
    return 'UR::DataSource::'.$driver;
}

sub _get_current_entities {
    my $self = shift;
    my @class_meta = UR::Object::Type->is_loaded(
        data_source_id => $self->id
    );
    my @objects;
    for my $class_meta (@class_meta) {
        next unless $class_meta->generated();  # Ungenerated classes won't have any instances
        my $class_name = $class_meta->class_name;
        push @objects, $UR::Context::current->all_objects_loaded($class_name);
    }
    return @objects;
}


sub _prepare_for_lob { };

sub _set_specified_objects_saved_uncommitted {
    my ($self,$objects_arrayref) = @_;
    # Sets an objects as though the has been saved but tha changes have not been committed.
    # This is called automatically by _sync_databases.

    my %objects_by_class;
    my $class_name;
    for my $object (@$objects_arrayref) {
        $class_name = ref($object);
        $objects_by_class{$class_name} ||= [];
        push @{ $objects_by_class{$class_name} }, $object;
    }

    for my $class_name (sort keys %objects_by_class) {
        my $class_object = $class_name->__meta__;
        my @property_names =
            map { $_->property_name }
            grep { $_->column_name }
            $class_object->all_property_metas;

        for my $object (@{ $objects_by_class{$class_name} }) {
            $object->{db_saved_uncommitted} ||= {};
            my $db_saved_uncommitted = $object->{db_saved_uncommitted};
            for my $property ( @property_names ) {
                $db_saved_uncommitted->{$property} = $object->$property;
            }
        }
    }
    return 1;
}

sub _set_all_objects_saved_committed {
    # called by UR::DBI on commit
    my $self = shift;
    return $self->_set_specified_objects_saved_committed([ $self->_get_current_entities ]);
}

sub _set_all_specified_objects_saved_committed {
    my $self = shift;
    my($pkg, $file, $line) = caller;
    Carp::carp("Deprecated method _set_all_specified_objects_saved_committed called at file $file line $line.  The new name for this method is _set_specified_objects_saved_committed");
    my @changed_objects = @_;
    $self->_set_specified_objects_saved_committed(\@changed_objects);
}

sub _set_specified_objects_saved_committed {
    my $self = shift;
    my $objects = shift;

    # Two step process... set saved and committed, then fire commit observers.
    # Doing so prevents problems should any of the observers themselves commit.
    my @saved_objects;
    for my $obj (@$objects) {
        my $saved = $self->_set_object_saved_committed($obj);
        push @saved_objects, $saved if $saved;
    }

    for my $obj (@saved_objects) {
        next if $obj->isa('UR::DeletedRef');
        $obj->__signal_change__('commit');
        if ($obj->isa('UR::Object::Ghost')) {
            $UR::Context::current->_abandon_object($obj);
        }
    }

    return scalar(@$objects) || "0 but true";
}

sub _set_object_saved_committed {
    # called by the above, and some test cases
    my ($self, $object) = @_;
    if ($object->{db_saved_uncommitted}) {
        unless ($object->isa('UR::Object::Ghost')) {
            %{ $object->{db_committed} } = (
                ($object->{db_committed} ? %{ $object->{db_committed} } : ()),
                %{ $object->{db_saved_uncommitted} }
            );
            delete $object->{db_saved_uncommitted};
        }
        return $object;
    }
    else {
        return;
    }
}

sub _set_all_objects_saved_rolled_back {
    # called by UR::DBI on commit
    my $self = shift;
    my @objects = $self->_get_current_entities;
    for my $obj (@objects)  {
        unless ($self->_set_object_saved_rolled_back($obj)) {
            die "An error occurred setting " . $obj->__display_name__
             . " to match the rolled-back database state.  Exiting...";
        }
    }
}

sub _set_specified_objects_saved_rolled_back {
    my $self = shift;
    my $objects = shift;
    for my $obj (@$objects)  {
        unless ($self->_set_object_saved_rolled_back($obj)) {
            die "An error occurred setting " . $obj->__display_name__
             . " to match the rolled-back database state.  Exiting...";
        }
    }
}



sub _set_object_saved_rolled_back {
    # called by the above, and some test cases
    my ($self,$object) = @_;
    delete $object->{db_saved_uncommitted};
    return $object;
}


# These are part of the basic DataSource API.  Subclasses will want to override these

sub _sync_database {
    my $class = shift;
    my %args = @_;
    $class = ref($class) || $class;

    $class->warning_message("Data source $class does not support saving objects to storage.  " . 
                            scalar(@{$args{'changed_objects'}}) . " objects will not be saved");
    return 1;
}

sub commit {
    my $class = shift;
    my %args = @_;
    $class = ref($class) || $class;

    #$class->warning_message("commit() ignored for data source $class");
    return 1;
}

sub rollback {
    my $class = shift;
    my %args = @_;
    $class = ref($class) || $class;

    $class->warning_message("rollback() ignored for data source $class");
    return 1;
}

# When the class initializer is create property objects, it will
# auto-fill-in column_name if the class definition has a table_name.
# File-based data sources do not have tables (and so classes using them
# do not have table_names), but the properties still need column_names
# so loading works properly.
# For now, only UR::DataSource::File and ::FileMux set this.
# FIXME this method's existence is ugly.  Find a better way to fill in
# column_name for those properties, or fix the data sources to not
# require column_names to be set by the initializer
sub initializer_should_create_column_name_for_class_properties {
    return 0;
}


# Subclasses should override this.
# It's called by the class initializer when the data_source property in a class
# definition contains a hashref with an 'is' key.  The method should accept this
# hashref, create a data_source instance (if appropriate) and return the class_name
# of this new datasource.
sub create_from_inline_class_data {
    my ($class,$class_data,$ds_data) = @_;
    my %ds_data = %$ds_data;
    my $ds_class_name = delete $ds_data{is};
    unless (my $ds_class_meta = UR::Object::Type->get($ds_class_name)) {
        die "No class $ds_class_name found!";
    }
    my $ds = $ds_class_name->__define__(%ds_data);
    unless ($ds) {
        die "Failed to construct $ds_class_name: " . $ds_class_name->error_message();
    }
    return $ds;
}

sub ur_data_type_for_data_source_data_type {
    my($class,$type) = @_;

    return [undef,undef];   # The default that should give reasonable behavior
}


# prepare_for_fork, do_after_fork_in_child, and finish_up_after_fork are no-op
# here in the UR::DataSource base class and should be implented in subclasses
# as needed.
sub prepare_for_fork { return 1 }
sub do_after_fork_in_child { return 1 }
sub finish_up_after_fork { return 1 }

sub _resolve_owner_and_table_from_table_name {
    my($self, $table_name) = @_;
    # Basic data sources don't know about owners/schemas
    return (undef, $table_name);
}

sub _resolve_table_and_column_from_column_name {
    my($self, $column_name) = @_;
    # Basic data sources don't know about tables
    return (undef,$column_name);
}

1;