view release on metacpan or  search on metacpan

lib/DB/Object.pm  view on Meta::CPAN

        local $@;
        my $sth_dbi = eval
        {
            local( $SIG{__DIE__} )  = sub{ };
            local( $SIG{__WARN__} ) = sub{ };
            $dbo->{dbh}->prepare_cached( $query, ( scalar( keys( %$prepare_options ) ) ? $prepare_options : () ) );
        };

        if( $@ )
        {
            $repo->unlock if( $repo );
            return( $self->error( "Error preparing cached SQL query: $@\nQuery was:\n$query" ) );
        }

        $sth->{sth} = $sth_dbi;
        $repo->unlock if( $repo );
    }

    # The statement is not cached anywhere, so we prepare it now
    if( !defined( $sth ) )
    {
        my $prepare_options = {};
        if( $q && $self->_is_a( $q, "${base_class}::Query" ) )
        {
            $prepare_options = $q->prepare_options->as_hash;
        }

        if( !( $sth = $dbo->prepare( $query, ( scalar( keys( %$prepare_options ) ) ? $prepare_options : () ) ) ) )
        {
            $repo->unlock if( $repo );
            return( $self->pass_error( $dbo->error ) );
        }

        # File cache (explicit mode only)
        if( $cache && $use_file_cache && $cache_file )
        {
            if( !$dbo->Module::Generic::serialise( $sth,
                file       => $cache_file,
                lock       => 1,
                serialiser => $serialiser,
            ) )
            {
                $repo->unlock if( $repo );
                return( $self->pass_error( $dbo->error ) );
            }
        }
        # If caching is off, but the query is a binded parameters' one,
        # make the current object hold the statement object
        elsif( $bind )
        {
            $self->{sth} = $sth;
        }
        $repo->unlock if( $repo );
    }
    else
    {
        $repo->unlock if( $repo );
    }

    # Ensure we unlock even if sth came from mem cache path where we unlocked earlier
    $repo->unlock if( $repo );

    # Attach query object to statement (this can be dangerous if the statement is long-lived;
    # keep your query object small / reset/dirty it aggressively)
    $sth->query_object( $q ) if( $dbo->_is_a( $q, "${base_class}::Query" ) );
    $sth->table_object( $self ) if( $self->isa( "${base_class}::Tables" ) );

    # Caching the query as a constant
    if( $q && $dbo->_is_object( $q ) && $q->isa( "${base_class}::Query" ) )
    {
        my $constant = $q->constant;
        if( $constant && scalar( keys( %$constant ) ) )
        {
            foreach my $k (qw( pack file line ))
            {
                return( $self->error( "Could not find the parameter \"$k\" in the constant query hash reference." ) ) if( !$constant->{ $k } );
            }

            # We temporarily not store the query object, and see if this affects positively the memory consumption.
            # $constant->{query_object} = $q;
            # $dbo->constant_queries_cache_set( $constant );
        }
    }

    return( $sth );
}

sub _check_connect_param
{
    my $self  = shift( @_ );
    my $param = shift( @_ );
    my $valid = $self->_connection_parameters( $param );
    my $opts  = $self->_connection_options( $param );
    foreach my $k ( keys( %$param ) )
    {
        # If it is not in the list and it does not start with an upper case; those are like RaiseError, AutoCommit, etc
        if( CORE::length( $param->{ $k } ) && !grep( /^$k$/, @$valid ) && !CORE::exists( $opts->{ $k } ) )
        {
            return( $self->error( "Invalid parameter '$k'." ) );
        }
    }
    my @opts_to_remove = keys( %$opts );
    CORE::delete( @$param{ @opts_to_remove } ) if( scalar( @opts_to_remove ) );
    $param->{opt} = $opts;
    $param->{database} = CORE::delete( $param->{db} ) if( !length( $param->{database} ) && $param->{db} );
    return( $param );
}

sub _check_default_option
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    # return( $self->error( "Provided option is not a hash reference." ) ) if( !$self->_is_hash( $opts ) );
    # This method should be superseded by an inherited class
    return( $opts );
}

# Simplistic clone by design. We do not want a recursive clone like Clone::clone()
sub _clone
{