view release on metacpan or  search on metacpan

lib/Bio/MAGETAB/Util/DBLoader.pm  view on Meta::CPAN

    else {
        $data->{'namespace'} ||= $self->get_namespace();
        $data->{'authority'} ||= $self->get_authority();
    }
}

sub _query_database {

    my ( $self, $class, $data, $id_fields ) = @_;

    unless ( first { defined $data->{ $_ } } @{ $id_fields } ) {
        my $allowed = join(', ', @{ $id_fields });
        confess(qq{Error: No identifying attributes for $class.}
              . qq{ Must use at least one of the following: $allowed.\n});
    }

    my $remote = $self->remote( $class );

    my ( $clean_data, $aggregators )
        = $self->_strip_aggregator_info( $class, $data );

    # Add authority, namespace to $id_fields unless $data has a
    # termSource.  Also, TermSources themselves are *always* treated
    # as global in this way.
    my %tmp_fields = map { $_ => 1 } @{ $id_fields }, qw( namespace authority );
    $id_fields = [ keys %tmp_fields ];
    $self->_manage_namespace_authority( $data, $class );

    my $filter;
    FIELD:
    foreach my $field ( @{ $id_fields } ) {

        my $value = $data->{ $field };

        # Don't add aggregator fields to the query (the schema doesn't
        # know about them).
        next FIELD if ( first { $field eq $_ } @{ $aggregators } );

        # Skip the field if it's looking for a dummy object not in the
        # database yet.
        next FIELD if ( UNIVERSAL::isa( $value, 'Bio::MAGETAB::BaseClass' )
            && ! $self->id( $value ) );

        # Another special case - URI can change in the model
        # between input and output (specifically, a file: prefix
        # may be added). This is copied from
        # Bio::MAGETAB::Types. FIXME date will need the same
        # treatment.
        if ( defined $value && $field eq 'uri' ) {
            use URI;
            $value = URI->new( $value );

            # We assume here that thet default URI scheme is "file".
            unless ( $value->scheme() ) {
                $value->scheme('file');
            }
        }

        # Warn the user about a known Tangram bug.
        if ( $value && $value =~ /\%/ ) {
            warn("Warning: ID fields containing the percent character (%) may"
                ." lead to problems with object retrieval. See the documentation for "
                .__PACKAGE__." for a discussion of this bug.\n");
        }

        {
            # Tangram::Expr treats undef as IS NULL.
            no warnings qw( uninitialized );

            # Much operator overloading means that we have to be
            # careful here.
            eval {
                my $expr;
                if ( blessed $value ) {
                    $expr = ( $remote->{ $field } == $value );
                }
                else {
                    $expr = ( $remote->{ $field } eq $value );
                }

                if ( $filter ) {
                    $filter &= ( $expr );
                }
                else {
                    $filter  = ( $expr );
                }
            };
            if ( $EVAL_ERROR ) {
                croak("Error constructing filter for $field == $value: $EVAL_ERROR")
            }

            # End of 'no warnings' pragma.
        }
    }

    # Find objects matching the ID fields.
    my @objects = $self->select( $remote, $filter );

    # We deal with aggregators in a second select at this point. Not
    # terribly efficient, but the model limits us here.
    foreach my $agg_field ( @{ $aggregators } ) {
        my $agg = $data->{ $agg_field };
        unless ( defined $agg ) {
            confess("Error: Undefined aggregator field for class $class.");
        }
        my @attr = $agg->meta()->get_all_attributes();
        my %map = map { $_->type_constraint()->name() => $_->name() } @attr;

        my ( $is_list, $target, $method );
        ATTR:
        while ( my ( $constraint, $attr ) = each %map ) {
            ( $is_list, $target ) = ( $constraint =~ /\A (ArrayRef)? \[? ([^\[\]]+) \]? \z/xms );

            unless ( $target ) {
                confess("Error: Moose type constraint name not parseable");
            }
            if ( UNIVERSAL::isa( $class, $target ) ) {
                $method = $attr;
                last ATTR;
            }
        }