File Coverage

blib/lib/DBD/Mock.pm

Criterion	Covered	Total	%
statement	49	52	94.2
branch	6	8	75.0
condition	3	6	50.0
subroutine	16	18	88.8
pod	0	1	0.0
total	74	85	87.0

package DBD::Mock;

# --------------------------------------------------------------------------- #
#   Copyright (c) 2004-2007 Stevan Little, Chris Winters
#   (spawned from original code Copyright (c) 1994 Tim Bunce)
# --------------------------------------------------------------------------- #
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
# --------------------------------------------------------------------------- #

use 5.008001;

use strict;
use warnings;

use DBI;

use DBD::Mock::dr;
use DBD::Mock::db;
use DBD::Mock::st;
use DBD::Mock::StatementTrack;
use DBD::Mock::StatementTrack::Iterator;
use DBD::Mock::Session;
use DBD::Mock::Pool;
use DBD::Mock::Pool::db;

sub import {
    shift;
    $DBI::connect_via = "DBD::Mock::Pool::connect"
      if ( @_ && lc( $_[0] ) eq "pool" );
}

our $VERSION = '1.59';

our $drh    = undef;    # will hold driver handle
our $err    = 0;        # will hold any error codes
our $errstr = '';       # will hold any error messages

# Defaulting a result set's fields to undef changes the way DBD::Mock responds, so we default it to off
our $DefaultFieldsToUndef = 0;


sub driver {
    return $drh if defined $drh;
    my ( $class, $attributes ) = @_;
    $attributes = {}
      unless ( defined($attributes) && ( ref($attributes) eq 'HASH' ) );
    $drh = DBI::_new_drh(
        "${class}::dr",
        {
            Name    => 'Mock',
            Version => $DBD::Mock::VERSION,
            Attribution =>
'DBD Mock driver by Chris Winters & Stevan Little (orig. from Tim Bunce)',
            Err    => \$DBD::Mock::err,
            Errstr => \$DBD::Mock::errstr,

            # mock attributes
            mock_connect_fail => 0,

            # and pass in any extra attributes given
            %{$attributes}
        }
    );
    return $drh;
}

sub CLONE { undef $drh }

# NOTE:
# this feature is still quite experimental. It is defaulted to
# be off, but it can be turned on by doing this:
#    $DBD::Mock::AttributeAliasing++;
# and then turned off by doing:
#    $DBD::Mock::AttributeAliasing = 0;
# we shall see how this feature works out.

our $AttributeAliasing = 0;

my %AttributeAliases = (
    mysql => {
        db => {

            # aliases can either be a string which is obvious
            mysql_insertid => 'mock_last_insert_id'
        },
        st => {

            # but they can also be a subroutine reference whose
            # first argument will be either the $dbh or the $sth
            # depending upon which context it is aliased in.
            mysql_insertid =>
              sub { (shift)->{Database}->{'mock_last_insert_id'} }
        }
    },

    mariadb => {
        db => {
            mariadb_insertid => 'mock_last_insert_id'
        },
        st => {
            mariadb_insertid =>
              sub { (shift)->{Database}->{'mock_last_insert_id'} }
        }
    }
);

sub _get_mock_attribute_aliases {
    my ($dbname) = @_;
    ( exists $AttributeAliases{ lc($dbname) } )
      || die "Attribute aliases not available for '$dbname'";
    return $AttributeAliases{ lc($dbname) };
}

sub _set_mock_attribute_aliases {
    my ( $dbname, $dbh_or_sth, $key, $value ) = @_;
    return $AttributeAliases{ lc($dbname) }->{$dbh_or_sth}->{$key} = $value;
}

## Some useful constants

use constant NULL_RESULTSET => [ [] ];

1;

__END__