...
 
Commits (8)
......@@ -7,21 +7,19 @@ use warnings;
my $build = Module::Build->new(
module_name => 'DBD::Mock',
license => 'perl',
requires => {
license => 'perl',
requires => {
'perl' => '5.6.0',
'DBI' => 1.30,
},
optional => {
'DBI' => 1.30,
},
optional => {},
build_requires => {
'Test::More' => '0.47',
'Test::More' => '0.47',
'Test::Exception' => '0.31',
},
create_makefile_pl => 'traditional',
create_makefile_pl => 'traditional',
recursive_test_files => 1,
add_to_cleanup => [
'*.bak',
],
add_to_cleanup => [ '*.bak', ],
);
$build->create_build_script;
Revision history for Perl extension DBD::Mock.
1.43
- Segregated into different packages
- Removed code coverage from POD
- Fixed bug rt49537 Basic support for named parameters
- Fixed bug rt70421 Build.PL now contains Test::Exception
1.42
- Fixed bug rt66815 DBD::Mock::Session error clobbered
- Fixed bug rt69460 Info on META.yml is outdated
......
# Note: this file was auto-generated by Module::Build::Compat version 0.30
require 5.6.0;
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'DBD::Mock',
'VERSION_FROM' => 'lib/DBD/Mock.pm',
'PREREQ_PM' => {
'DBI' => '1.3',
'Test::More' => '0.47',
'Test::Exception' => '0.31'
},
'INSTALLDIRS' => 'site',
'EXE_FILES' => [],
'PL_FILES' => {}
);
This diff is collapsed.
package DBD::Mock::Pool;
use strict;
use warnings;
my $connection;
sub connect {
return $connection if $connection;
# according to the code before my tweaks, this could be a class
# name, but it was never used - DR, 2008-11-08
shift unless ref $_[0];
my $drh = shift;
return $connection = bless $drh->connect(@_), 'DBD::Mock::Pool::db';
}
1;
package DBD::Mock::Pool::db;
use strict;
use warnings;
our @ISA = qw(DBI::db);
sub disconnect { 1 }
1;
package DBD::Mock::Session;
use strict;
use warnings;
my $INSTANCE_COUNT = 1;
sub new {
my $class = shift;
(@_) || die "You must specify at least one session state";
my $session_name;
if ( ref( $_[0] ) ) {
$session_name = 'Session ' . $INSTANCE_COUNT;
}
else {
$session_name = shift;
}
my @session_states = @_;
(@session_states)
|| die "You must specify at least one session state";
( ref($_) eq 'HASH' )
|| die "You must specify session states as HASH refs"
foreach @session_states;
$INSTANCE_COUNT++;
return bless {
name => $session_name,
states => \@session_states,
state_index => 0
} => $class;
}
sub name { (shift)->{name} }
sub reset { (shift)->{state_index} = 0 }
sub num_states { scalar( @{ (shift)->{states} } ) }
sub current_state {
my $self = shift;
my $idx = $self->{state_index};
return $self->{states}[$idx];
}
sub has_states_left {
my $self = shift;
return $self->{state_index} < scalar( @{ $self->{states} } );
}
sub verify_statement {
my ( $self, $dbh, $statement ) = @_;
( $self->has_states_left )
|| die "Session states exhausted, only '"
. scalar( @{ $self->{states} } )
. "' in DBD::Mock::Session ("
. $self->{name} . ")";
my $current_state = $self->current_state;
# make sure our state is good
( exists ${$current_state}{statement} && exists ${$current_state}{results} )
|| die "Bad state '"
. $self->{state_index}
. "' in DBD::Mock::Session ("
. $self->{name} . ")";
# try the SQL
my $SQL = $current_state->{statement};
unless ( ref($SQL) ) {
( $SQL eq $statement )
|| die
"Statement does not match current state in DBD::Mock::Session ("
. $self->{name} . ")\n"
. " got: $statement\n"
. " expected: $SQL";
}
elsif ( ref($SQL) eq 'Regexp' ) {
( $statement =~ /$SQL/ )
|| die
"Statement does not match current state (with Regexp) in DBD::Mock::Session ("
. $self->{name} . ")\n"
. " got: $statement\n"
. " expected: $SQL";
}
elsif ( ref($SQL) eq 'CODE' ) {
( $SQL->( $statement, $current_state ) )
|| die
"Statement does not match current state (with CODE ref) in DBD::Mock::Session ("
. $self->{name} . ")";
}
else {
die
"Bad 'statement' value '$SQL' in current state in DBD::Mock::Session ("
. $self->{name} . ")";
}
# copy the result sets so that
# we can re-use the session
$dbh->STORE( 'mock_add_resultset' => [ @{ $current_state->{results} } ] );
}
sub verify_bound_params {
my ( $self, $dbh, $params ) = @_;
my $current_state = $self->current_state;
if ( exists ${$current_state}{bound_params} ) {
my $expected = $current_state->{bound_params};
( scalar( @{$expected} ) == scalar( @{$params} ) )
|| die
"Not the same number of bound params in current state in DBD::Mock::Session ("
. $self->{name} . ")\n"
. " got: "
. scalar( @{$params} ) . "\n"
. " expected: "
. scalar( @{$expected} );
for ( my $i = 0 ; $i < scalar( @{$params} ) ; $i++ ) {
no warnings;
if ( ref( $expected->[$i] ) eq 'Regexp' ) {
( $params->[$i] =~ /$expected->[$i]/ )
|| die
"Bound param $i do not match (using regexp) in current state in DBD::Mock::Session ("
. $self->{name} . ")\n"
. " got: "
. $params->[$i] . "\n"
. " expected: "
. $expected->[$i];
}
else {
( $params->[$i] eq $expected->[$i] )
|| die
"Bound param $i do not match in current state in DBD::Mock::Session ("
. $self->{name} . ")\n"
. " got: "
. $params->[$i] . "\n"
. " expected: "
. $expected->[$i];
}
}
}
# and make sure we go to
# the next statement
$self->{state_index}++;
}
1;
package DBD::Mock::StatementTrack;
use strict;
use warnings;
sub new {
my ( $class, %params ) = @_;
# these params have default values
# but can be overridden
$params{return_data} ||= [];
$params{fields} ||= [];
$params{bound_params} ||= [];
$params{statement} ||= "";
$params{failure} ||= undef;
# these params should never be overridden
# and should always start out in a default
# state to assure the sanity of this class
$params{is_executed} = 'no';
$params{is_finished} = 'no';
$params{current_record_num} = 0;
# NOTE:
# changed from \%params here because that
# would bind the hash sent in so that it
# would reflect alterations in the object
# this violates encapsulation
my $self = bless {%params}, $class;
return $self;
}
sub has_failure {
my ($self) = @_;
$self->{failure} ? 1 : 0;
}
sub get_failure {
my ($self) = @_;
@{ $self->{failure} };
}
sub num_fields {
my ($self) = @_;
return scalar @{ $self->{fields} };
}
sub num_rows {
my ($self) = @_;
return scalar @{ $self->{return_data} };
}
sub num_params {
my ($self) = @_;
return scalar @{ $self->{bound_params} };
}
sub bind_col {
my ( $self, $param_num, $ref ) = @_;
$self->{bind_cols}->[ $param_num - 1 ] = $ref;
}
sub bound_param {
my ( $self, $param_num, $value ) = @_;
# Basic support for named parameters
if ( $param_num !~ /^\d+/ ) {
$param_num = $self->num_params + 1;
}
$self->{bound_params}->[ $param_num - 1 ] = $value;
return $self->bound_params;
}
sub bound_param_trailing {
my ( $self, @values ) = @_;
push @{ $self->{bound_params} }, @values;
}
sub bind_cols {
my $self = shift;
return @{ $self->{bind_cols} || [] };
}
sub bind_params {
my ( $self, @values ) = @_;
@{ $self->{bound_params} } = @values;
}
# Rely on the DBI's notion of Active: a statement is active if it's
# currently in a SELECT and has more records to fetch
sub is_active {
my ($self) = @_;
return 0 unless $self->statement =~ /^\s*select/ism;
return 0 unless $self->is_executed eq 'yes';
return 0 if $self->is_depleted;
return 1;
}
sub is_finished {
my ( $self, $value ) = @_;
if ( defined $value && $value eq 'yes' ) {
$self->{is_finished} = 'yes';
$self->current_record_num(0);
$self->{return_data} = [];
}
elsif ( defined $value ) {
$self->{is_finished} = 'no';
}
return $self->{is_finished};
}
####################
# RETURN VALUES
sub mark_executed {
my ($self) = @_;
$self->is_executed('yes');
$self->current_record_num(0);
}
sub next_record {
my ($self) = @_;
return if $self->is_depleted;
my $rec_num = $self->current_record_num;
my $rec = $self->return_data->[$rec_num];
$self->current_record_num( $rec_num + 1 );
return $rec;
}
sub is_depleted {
my ($self) = @_;
return ( $self->current_record_num >= scalar @{ $self->return_data } );
}
# DEBUGGING AID
sub to_string {
my ($self) = @_;
return join "\n" => (
$self->{statement},
"Values: [" . join( '] [', @{ $self->{bound_params} } ) . "]",
"Records: on $self->{current_record_num} of "
. scalar( @{ $self->return_data } ) . "\n",
"Executed? $self->{is_executed}; Finished? $self->{is_finished}"
);
}
# PROPERTIES
# boolean
sub is_executed {
my ( $self, $yes_no ) = @_;
$self->{is_executed} = $yes_no if defined $yes_no;
return ( $self->{is_executed} eq 'yes' ) ? 'yes' : 'no';
}
# single-element fields
sub statement {
my ( $self, $value ) = @_;
$self->{statement} = $value if defined $value;
return $self->{statement};
}
sub current_record_num {
my ( $self, $value ) = @_;
$self->{current_record_num} = $value if defined $value;
return $self->{current_record_num};
}
# multi-element fields
sub return_data {
my ( $self, @values ) = @_;
push @{ $self->{return_data} }, @values if scalar @values;
return $self->{return_data};
}
sub fields {
my ( $self, @values ) = @_;
push @{ $self->{fields} }, @values if scalar @values;
return $self->{fields};
}
sub bound_params {
my ( $self, @values ) = @_;
push @{ $self->{bound_params} }, @values if scalar @values;
return $self->{bound_params};
}
1;
package DBD::Mock::StatementTrack::Iterator;
use strict;
use warnings;
sub new {
my ( $class, $history ) = @_;
bless {
pointer => 0,
history => $history || []
} => $class;
}
sub next {
my ($self) = @_;
return unless $self->{pointer} < scalar( @{ $self->{history} } );
return $self->{history}->[ $self->{pointer}++ ];
}
sub reset { (shift)->{pointer} = 0 }
1;
This diff is collapsed.
package DBD::Mock::dr;
use strict;
use warnings;
our $imp_data_size = 0;
sub connect {
my ( $drh, $dbname, $user, $auth, $attributes ) = @_;
if ( $drh->{'mock_connect_fail'} == 1 ) {
$drh->set_err( 1, "Could not connect to mock database" );
return;
}
$attributes ||= {};
if ( $dbname && $DBD::Mock::AttributeAliasing ) {
# this is the DB we are mocking
$attributes->{mock_attribute_aliases} =
DBD::Mock::_get_mock_attribute_aliases($dbname);
$attributes->{mock_database_name} = $dbname;
}
# holds statement parsing coderefs/objects
$attributes->{mock_parser} = [];
# holds all statements applied to handle until manually cleared
$attributes->{mock_statement_history} = [];
# ability to fake a failed DB connection
$attributes->{mock_can_connect} = 1;
# ability to make other things fail :)
$attributes->{mock_can_prepare} = 1;
$attributes->{mock_can_execute} = 1;
$attributes->{mock_can_fetch} = 1;
my $dbh = DBI::_new_dbh( $drh, { Name => $dbname } )
|| return;
return $dbh;
}
sub FETCH {
my ( $drh, $attr ) = @_;
if ( $attr =~ /^mock_/ ) {
if ( $attr eq 'mock_connect_fail' ) {
return $drh->{'mock_connect_fail'};
}
elsif ( $attr eq 'mock_data_sources' ) {
unless ( defined $drh->{'mock_data_sources'} ) {
$drh->{'mock_data_sources'} = ['DBI:Mock:'];
}
return $drh->{'mock_data_sources'};
}
else {
return $drh->SUPER::FETCH($attr);
}
}
else {
return $drh->SUPER::FETCH($attr);
}
}
sub STORE {
my ( $drh, $attr, $value ) = @_;
if ( $attr =~ /^mock_/ ) {
if ( $attr eq 'mock_connect_fail' ) {
return $drh->{'mock_connect_fail'} = $value ? 1 : 0;
}
elsif ( $attr eq 'mock_data_sources' ) {
if ( ref($value) ne 'ARRAY' ) {
$drh->set_err( 1,
"You must pass an array ref of data sources" );
return;
}
return $drh->{'mock_data_sources'} = $value;
}
elsif ( $attr eq 'mock_add_data_sources' ) {
return push @{ $drh->{'mock_data_sources'} } => $value;
}
}
else {
return $drh->SUPER::STORE( $attr, $value );
}
}
sub data_sources {
my $drh = shift;
return
map { (/^DBI\:Mock\:/i) ? $_ : "DBI:Mock:$_" }
@{ $drh->FETCH('mock_data_sources') };
}
# Necessary to support DBI < 1.34
# from CPAN RT bug #7057
sub disconnect_all {
# no-op
}
sub DESTROY { undef }
1;
This diff is collapsed.
use strict;
use warnings;
use Test::More tests => 5;
BEGIN {
use_ok('DBD::Mock');
}
my $dbh = DBI->connect( 'DBI:Mock:', '', '' );
my $session = DBD::Mock::Session->new(
(
{
statement => 'SELECT * FROM foo WHERE id = ? and active = ?',
bound_params => [ '613', 'yes' ],
results => [ ['foo'], [10] ]
},
{
statement => 'SELECT * FROM foo WHERE id = ? and active = ?',
bound_params => [ '613', 'yes' ],
results => [ ['foo'], [10] ]
},
{
statement =>
'SELECT * FROM foo WHERE id = :id and active = :active',
bound_params => [ '101', 'no' ],
results => [ ['bar'], [15] ]
},
{
statement =>
'SELECT * FROM foo WHERE id = :id and active = :active',
bound_params => [ '101', 'no' ],
results => [ ['bar'], [15] ]
},
)
);
$dbh->{mock_session} = $session;
my $sth = $dbh->prepare('SELECT * FROM foo WHERE id = ? and active = ?');
$sth->bind_param( 1 => '613' );
$sth->bind_param( 2 => 'yes' );
ok( $sth->execute, 'Execute using positional parameters' );
$sth = $dbh->prepare('SELECT * FROM foo WHERE id = ? and active = ?');
ok( $sth->execute( '613', 'yes' ), 'Execute using positional parameters #2' );
$sth = $dbh->prepare('SELECT * FROM foo WHERE id = :id and active = :active');
$sth->bind_param( ':id' => '101' );
$sth->bind_param( ':active' => 'no' );
ok( $sth->execute, 'Execute using named parameters' );
$sth = $dbh->prepare('SELECT * FROM foo WHERE id = :id and active = :active');
ok( $sth->execute( '101', 'no' ), 'Execute using named parameters #2' );
......@@ -5,6 +5,7 @@ use Test::More;
eval "use Test::Pod::Coverage 1.04";
plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
all_pod_coverage_ok({
plan tests => 1;
pod_coverage_ok( 'DBD::Mock' ,{
trustme => [ qr/CLONE|driver/ ],
});