File Coverage

blib/lib/DBD/Mock/db.pm

Criterion	Covered	Total	%
statement	235	244	96.3
branch	134	152	88.1
condition	26	38	68.4
subroutine	18	18	100.0
pod	0	10	0.0
total	413	462	89.3

package DBD::Mock::db;

use strict;
use warnings;

use List::Util qw( first );
use DBI;

our $imp_data_size = 0;

sub ping {
    my ($dbh) = @_;
    return $dbh->{mock_can_connect};
}

sub last_insert_id {
    my ($dbh) = @_;
    return $dbh->{mock_last_insert_id};
}

sub get_info {
    my ( $dbh, $attr ) = @_;
    $dbh->{mock_get_info} ||= {};
    return $dbh->{mock_get_info}{$attr};
}

sub table_info {
    my ( $dbh, @params ) = @_;

    my ($cataloge, $schema, $table, $type) = map { $_ || '' } @params[0..4];

    $dbh->{mock_table_info} ||= {};

    my @tables = @{ $dbh->{mock_table_info}->{ $cataloge }->{ $schema }->{ $table }->{ $type } || [] };

    my ($fieldNames, @rows) = map { [ @$_ ] } @tables;

    $fieldNames ||= [];

    my $sponge = DBI->connect('dbi:Sponge:', '', '' )
        or return $dbh->DBI::set_err($DBI::err, "DBI::Sponge: $DBI::errstr");

    my $sth = $sponge->prepare("table_info", {
        rows          => \@rows,
        NUM_OF_FIELDS => scalar @$fieldNames,
        NAME          => $fieldNames
    }) or return $dbh->DBI::set_err( $sponge->err(), $sponge->errstr() );

    return $sth;
}

sub prepare {
    my ( $dbh, $statement ) = @_;

    unless ( $dbh->{mock_can_connect} ) {
        $dbh->set_err( 1, "No connection present" );
        return;
    }
    unless ( $dbh->{mock_can_prepare} ) {
        $dbh->set_err( 1, "Cannot prepare" );
        return;
    }
    $dbh->{mock_can_prepare}++ if $dbh->{mock_can_prepare} < 0;

    eval {
        foreach my $parser ( @{ $dbh->{mock_parser} } )
        {
            if ( ref($parser) eq 'CODE' ) {
                $parser->($statement);
            }
            else {
                $parser->parse($statement);
            }
        }
    };
    if ($@) {
        my $parser_error = $@;
        chomp $parser_error;
        $dbh->set_err( 1,
"Failed to parse statement. Error: ${parser_error}. Statement: ${statement}"
        );
        return;
    }

    my $sth = DBI::_new_sth( $dbh, { Statement => $statement } );
    $sth->trace_msg( "Preparing statement '${statement}'\n", 1 );
    my %track_params = ( statement => $statement );

    if ( my $session = $dbh->{mock_session} ) {
        eval {
            my $rs = $session->results_for($statement);
            if ( ref($rs) eq 'ARRAY' && scalar( @{$rs} ) > 0 ) {
                my $fields = @{$rs}[0];
                $track_params{return_data} = $rs;
                $track_params{fields}      = $fields;
                $sth->STORE( NAME          => $fields );
                $sth->STORE( NUM_OF_FIELDS => scalar @{$fields} );
            }
            else {
                $sth->trace_msg( "No return data set in DBH\n", 1 );
            }
        };

        if ($@) {
            $dbh->DBI::set_err( 1, "Session Error: $@. Statement: $statement" );
        }

    }

    else {
        # If we have available resultsets seed the tracker with one

        my ($rs, $callback, $failure, $prepare_attributes, $execute_attributes);

        if ( my $all_rs = $dbh->{mock_rs} ) {
            if ( my $by_name = defined $all_rs->{named}{$statement} ? $all_rs->{named}{$statement} : first { $statement =~ m/$_->{regexp}/ } @{ $all_rs->{matching} } ) {
                # We want to copy this, because it is meant to be reusable
                $rs = [ @{ $by_name->{results} } ];
                $callback = $by_name->{callback};
                $failure = $by_name->{failure};
                $prepare_attributes = $by_name->{prepare_attributes};
                $execute_attributes = $by_name->{execute_attributes};
            }
            else {
                $rs = shift @{ $all_rs->{ordered} };
                if (ref($rs) eq 'HASH') {
                    $callback = $rs->{callback};
                    $failure = $rs->{failure};
                    $prepare_attributes = $rs->{prepare_attributes};
                    $execute_attributes = $rs->{execute_attributes};
                    $rs = [ @{ $rs->{results} } ];
                }
            }
        }

        if ( ref($rs) eq 'ARRAY' && ( scalar( @{$rs} ) > 0 || $callback ) ) {
            my $fields = shift @{$rs};
            $track_params{return_data}        = $rs;
            $track_params{fields}             = $fields;
            $track_params{callback}           = $callback;
            $track_params{failure}            = $failure;
            $track_params{driver_attributes}  = $prepare_attributes;
            $track_params{execute_attributes} = $execute_attributes;

            if( $fields ) {
                $sth->STORE( NAME          => $fields );
                $sth->STORE( NUM_OF_FIELDS => scalar @{$fields});
            }

        }
        else {
            $sth->trace_msg( "No return data set in DBH\n", 1 );
        }

    }

    # do not allow a statement handle to be created if there is no
    # connection present.

    unless ( $dbh->FETCH('Active') ) {
        $dbh->set_err( 1, "No connection present" );
        return;
    }

    # This history object will track everything done to the statement
    my $history = DBD::Mock::StatementTrack->new(%track_params);
    $sth->STORE( mock_my_history => $history );

    # ...now associate the history object with the database handle so
    # people can browse the entire history at once, even for
    # statements opened and closed in a black box

    my $all_history = $dbh->FETCH('mock_statement_history');
    push @{$all_history}, $history;

    return $sth;
}

*prepare_cached = \&prepare;

{
    my $begin_work_commit;

    sub begin_work {
        my $dbh = shift;
        if ( $dbh->FETCH('AutoCommit') ) {
            $dbh->STORE( 'AutoCommit', 0 );
            $begin_work_commit = 1;
            my $sth = $dbh->prepare('BEGIN WORK')
              or return $dbh->set_err( 1, $DBI::errstr );
            my $rc = $sth->execute()
              or return $dbh->set_err( 1, $DBI::errstr );
            $sth->finish();
            return $rc;
        }
        else {
            return $dbh->set_err( 1,
                'AutoCommit is off, you are already within a transaction' );
        }
    }

    sub commit {
        my $dbh = shift;
        if ( $dbh->FETCH('AutoCommit') && $dbh->FETCH('Warn') ) {
            return $dbh->set_err( 1, "commit ineffective with AutoCommit" );
        }

        my $sth = $dbh->prepare('COMMIT')
          or return $dbh->set_err( 1, $DBI::errstr );
        my $rc = $sth->execute()
          or return $dbh->set_err( 1, $DBI::errstr );
        $sth->finish();

        if ($begin_work_commit) {
            $dbh->STORE( 'AutoCommit', 1 );
            $begin_work_commit = 0;
        }

        return $rc;
    }

    sub rollback {
        my $dbh = shift;
        if ( $dbh->FETCH('AutoCommit') && $dbh->FETCH('Warn') ) {
            return $dbh->set_err( 1, "rollback ineffective with AutoCommit" );
        }

        my $sth = $dbh->prepare('ROLLBACK')
          or return $dbh->set_err( 1, $DBI::errstr );
        my $rc = $sth->execute()
          or return $dbh->set_err( 1, $DBI::errstr );
        $sth->finish();

        if ($begin_work_commit) {
            $dbh->STORE( 'AutoCommit', 1 );
            $begin_work_commit = 0;
        }

        return $rc;
    }
}

# NOTE:
# this method should work in most cases, however it does
# not exactly follow the DBI spec in the case of error
# handling. I am not sure if that level of detail is
# really nessecary since it is a weird error conditon
# which causes it to fail anyway. However if you find you do need it,
# then please email me about it. I think it would be possible
# to mimic it by accessing the DBD::Mock::StatementTrack
# object directly.
sub selectcol_arrayref {
    my ( $dbh, $query, $attrib, @bindvalues ) = @_;

    # get all the columns ...
    my $a_ref = $dbh->selectall_arrayref( $query, $attrib, @bindvalues );

    # if we get nothing back, or dont get an
    # ARRAY ref back, then we can assume
    # something went wrong, and so return undef.
    return undef unless defined $a_ref || ref($a_ref) ne 'ARRAY';

    my @cols = 0;
    if ( ref $attrib->{Columns} eq 'ARRAY' ) {
        @cols = map { $_ - 1 } @{ $attrib->{Columns} };
    }

    # if we do get something then we
    # grab all the columns out of it.
    return [ map { @$_[@cols] } @{$a_ref} ];
}

sub FETCH {
    my ( $dbh, $attrib, $value ) = @_;
    $dbh->trace_msg("Fetching DB attrib '$attrib'\n");

    if ( $attrib eq 'Active' ) {
        return $dbh->{mock_can_connect};
    }
    elsif ( $attrib eq 'mock_all_history' ) {
        return $dbh->{mock_statement_history};
    }
    elsif ( $attrib eq 'mock_all_history_iterator' ) {
        return DBD::Mock::StatementTrack::Iterator->new(
            $dbh->{mock_statement_history} );
    }
    elsif ( $attrib =~ /^mock/ ) {
        return $dbh->{$attrib};
    }
    elsif ( $attrib =~ /^(private_|dbi_|dbd_|[A-Z])/ ) {
        $dbh->trace_msg(
            "... fetching non-driver attribute ($attrib) that DBI handles\n");
        return $dbh->SUPER::FETCH($attrib);
    }
    else {
        if ( $dbh->{mock_attribute_aliases} ) {
            if ( exists ${ $dbh->{mock_attribute_aliases}->{db} }{$attrib} ) {
                my $mock_attrib =
                  $dbh->{mock_attribute_aliases}->{db}->{$attrib};
                if ( ref($mock_attrib) eq 'CODE' ) {
                    return $mock_attrib->($dbh);
                }
                else {
                    return $dbh->FETCH($mock_attrib);
                }
            }
        }
        $dbh->trace_msg(
"... fetching non-driver attribute ($attrib) that DBI doesn't handle\n"
        );
        return $dbh->{$attrib};
    }
}

sub STORE {
    my ( $dbh, $attrib, $value ) = @_;

    my $printed_value = $value || 'undef';
    $dbh->trace_msg("Storing DB attribute '$attrib' with '$printed_value'\n");

    if ( $attrib eq 'AutoCommit' ) {

        # These are magic DBI values that say we can handle AutoCommit
        # internally as well
        $value = ($value) ? -901 : -900;
    }

    if ( $attrib eq 'mock_clear_history' ) {
        if ($value) {
            $dbh->{mock_statement_history} = [];
        }
        return [];
    }
    elsif ( $attrib eq 'mock_add_parser' ) {
        my $parser_type = ref($value);
        my $is_valid_parser;

        if ( $parser_type eq 'CODE' ) {
            $is_valid_parser++;
        }
        elsif ( $parser_type && $parser_type !~ /^(ARRAY|HASH|SCALAR)$/ ) {
            $is_valid_parser = eval { $parser_type->can('parse') };
        }

        unless ($is_valid_parser) {
            my $error =
                "Parser must be a code reference or object with 'parse()' "
              . "method (Given type: '$parser_type')";
            $dbh->set_err( 1, $error );
            return;
        }
        push @{ $dbh->{mock_parser} }, $value;
        return $value;
    }
    elsif ( $attrib eq 'mock_add_resultset' ) {
        my @copied_values;

        $dbh->{mock_rs} ||= {
            named   => {},
            ordered => [],
            matching => [],
        };

        if ( ref $value eq 'ARRAY' ) {
            @copied_values = @{$value};
            push @{ $dbh->{mock_rs}{ordered} }, \@copied_values;
        }
        elsif ( ref $value eq 'HASH' ) {
            my $name = $value->{sql};

            @copied_values = @{ $value->{results} ? $value->{results} : [] };

            if (not defined $name) {
                push @{ $dbh->{mock_rs}{ordered} }, {
                    results => \@copied_values,
                    callback => $value->{callback},
                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
                    prepare_attributes => $value->{prepare_attributes},
                    execute_attributes => $value->{execute_attributes},
                };
            }
            elsif ( ref $name eq "Regexp" ) {
                my $matching = {
                    regexp => $name,
                    results => \@copied_values,
                    callback => $value->{callback},
                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
                    prepare_attributes => $value->{prepare_attributes},
                    execute_attributes => $value->{execute_attributes},
                };
                # either replace existing match or push
                grep { $_->{regexp} eq $name && ($_ = $matching) } @{ $dbh->{mock_rs}{matching} }
                  or push @{ $dbh->{mock_rs}{matching} }, $matching;
            }
            else {
                $dbh->{mock_rs}{named}{$name} = {
                    results => \@copied_values,
                    callback => $value->{callback},
                    failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef,
                    prepare_attributes => $value->{prepare_attributes},
                    execute_attributes => $value->{execute_attributes},
                };
            }
        }
        else {
            die "Must provide an arrayref or hashref when adding ",
              "resultset via 'mock_add_resultset'.\n";
        }

        return \@copied_values;
    }
    elsif ( $attrib eq 'mock_start_insert_id' ) {
        if ( ref $value eq 'ARRAY' ) {
            $dbh->{mock_last_insert_ids} = {}
              unless $dbh->{mock_last_insert_ids};
            $dbh->{mock_last_insert_ids}{ $value->[0] } = $value->[1];
        }
        else {

            # we start at one minus the start id
            # so that the increment works
            $dbh->{mock_last_insert_id} = $value - 1;
        }

    }
    elsif ( $attrib eq 'mock_session' ) {
        ( ref($value) && UNIVERSAL::isa( $value, 'DBD::Mock::Session' ) )
          || die
"Only DBD::Mock::Session objects can be placed into the 'mock_session' slot\n"
          if defined $value;
        $dbh->{mock_session} = $value;
    }
    elsif ( $attrib =~ /^mock_(add_)?data_sources/ ) {
        $dbh->{Driver}->STORE( $attrib, $value );
    }
    elsif ( $attrib =~ /^mock_add_table_info$/ ) {
        $dbh->{mock_table_info} ||= {};

        if ( ref $value ne "HASH" ) {
            die "mock_add_table_info needs a hash reference"
        }

        my ( $cataloge, $schema, $table, $type ) = map { defined $_ ? $_ : '' } @$value{qw( cataloge schema table type )};

        $dbh->{mock_table_info}->{ $cataloge }->{ $schema }->{ $table }->{ $type } = $value->{table_info};
    }
    elsif ( $attrib =~ /^mock_clear_table_info$/ ) {
        if ( $value ) {
            $dbh->{mock_table_info} = {};
        }

        return {};
    }
    elsif ( $attrib =~ /^mock/ ) {
        return $dbh->{$attrib} = $value;
    }
    elsif ( $attrib =~ /^(private_|dbi_|dbd_|[A-Z])/ ) {
        $dbh->trace_msg(
"... storing non-driver attribute ($attrib) with value ($printed_value) that DBI handles\n"
        );
        return $dbh->SUPER::STORE( $attrib, $value );
    }
    else {
        $dbh->trace_msg(
"... storing non-driver attribute ($attrib) with value ($printed_value) that DBI won't handle\n"
        );
        return $dbh->{$attrib} = $value;
    }
}

sub DESTROY {
    my ($dbh) = @_;
    if ( my $session = $dbh->{mock_session} ) {
        if ( $session->has_states_left ) {
            die "DBH->finish called when session still has states left\n";
        }
    }
}

sub disconnect {
    my ($dbh) = @_;
    if ( my $session = $dbh->{mock_session} ) {
        if ( $session->has_states_left ) {
            die "DBH->finish called when session still has states left\n";
        }
    }
}

1;