...
 
Commits (16)
......@@ -20,6 +20,12 @@ my $build = Module::Build->new(
create_makefile_pl => 'traditional',
recursive_test_files => 1,
add_to_cleanup => [ '*.bak', ],
meta_merge => {
resources => {
repository => 'https://github.com/bluescreen10/dbd-mock',
},
},
);
$build->create_build_script;
Revision history for Perl extension DBD::Mock.
{{NEXT}}
- Add git-repo url to meta-data
1.43
- Segregated into different packages
- Removed code coverage from POD
......
Build.PL
Changes
lib/DBD/Mock.pm
lib/DBD/Mock/db.pm
lib/DBD/Mock/dr.pm
lib/DBD/Mock/Pool.pm
lib/DBD/Mock/Pool/db.pm
lib/DBD/Mock/Session.pm
lib/DBD/Mock/st.pm
lib/DBD/Mock/StatementTrack.pm
lib/DBD/Mock/StatementTrack/Iterator.pm
Makefile.PL
MANIFEST This list of files
MYMETA.json
MYMETA.yml
README
t/000_basic.t
t/001_db_handle.t
t/002_dr_handle.t
t/003_db_can_connect.t
t/004_misc_mock_attr.t
t/005_db_parser.t
t/006_prepare_cached.t
t/007_mock_attribute_aliases.t
t/008_db_connect_cached.t
t/009_info.t
t/010_rollback.t
t/011_st_execute_empty.t
t/012_st_handle.t
t/013_st_execute_bound_params.t
t/014_st_execute_pass_params.t
t/015_st_fetch_records.t
t/016_mock_add_resultset_test.t
t/017_st_can_connect.t
t/018_mock_statement_track.t
t/019_mock_statement_track_iterator.t
t/020_db_pool.t
t/021_DBD_Mock_Session.t
t/022_DBD_Mock_Session_bound_params.t
t/023_statement_failure.t
t/024_selcol_fetchhash.t
t/025_mock_last_insert_id.t
t/026_st_bind_col.t
t/027_named_parameters.t
t/028_bind_columns.t
t/029_multiple_prepare_statements.t
t/998_pod.t
t/999_pod_coverage.t
t/bug_0001.t
t/bug_0002.t
t/bug_0003.t
......@@ -30,7 +30,7 @@ sub import {
if ( @_ && lc( $_[0] ) eq "pool" );
}
our $VERSION = '1.43';
our $VERSION = '1.45';
our $drh = undef; # will hold driver handle
our $err = 0; # will hold any error codes
......
......@@ -5,33 +5,63 @@ use warnings;
my $INSTANCE_COUNT = 1;
# - Class - #
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;
my $name = ref( $_[0] ) ? "Session $INSTANCE_COUNT" : shift;
$INSTANCE_COUNT++;
return bless {
name => $session_name,
states => \@session_states,
$class->_verify_states( $name, @_ );
bless {
name => $name,
states => \@_,
state_index => 0
} => $class;
}, $class;
}
sub _verify_state {
my ( $class, $state, $index, $name ) = @_;
die "You must specify session states as HASH refs"
if ref($state) ne 'HASH';
die "Bad state '$index' in DBD::Mock::Session ($name)"
if not exists $state->{statement}
or not exists $state->{results};
my $stmt = $state->{statement};
my $ref = ref $stmt;
die "Bad 'statement' value '$stmt' in DBD::Mock::Session ($name)",
if ref($stmt) ne ''
and $ref ne 'CODE'
and $ref ne 'Regexp';
}
sub _verify_states {
my ( $class, $name, @states ) = @_;
die "You must specify at least one session state"
if scalar @states == 0;
for ( 0 .. scalar @states - 1 ) {
$class->_verify_state( $states[$_], $_, $name );
}
}
sub name { (shift)->{name} }
sub reset { (shift)->{state_index} = 0 }
sub num_states { scalar( @{ (shift)->{states} } ) }
# - Instance - #
sub name {
my $self = shift;
$self->{name};
}
sub reset {
my $self = shift;
$self->{state_index} = 0;
}
sub current_state {
my $self = shift;
......@@ -41,99 +71,66 @@ sub current_state {
sub has_states_left {
my $self = shift;
return $self->{state_index} < scalar( @{ $self->{states} } );
return $self->{state_index} < $self->_num_states;
}
sub verify_statement {
my ( $self, $dbh, $statement ) = @_;
my ( $self, $got ) = @_;
unless ( $self->has_states_left ) {
die "Session states exhausted, only '"
. $self->_num_states
. "' in DBD::Mock::Session ($self->name})";
}
( $self->has_states_left )
|| die "Session states exhausted, only '"
. scalar( @{ $self->{states} } )
. "' in DBD::Mock::Session ("
. $self->{name} . ")";
my $state = $self->current_state;
my $expected = $state->{statement};
my $ref = ref($expected);
my $current_state = $self->current_state;
if ( $ref eq 'Regexp' and $got !~ /$expected/ ) {
die "Statement does not match current state (with Regexp) in "
. "DBD::Mock::Session ($self->{name})\n"
. " got: $got\n"
. " expected: $expected",
# 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} . ")";
if ( $ref eq 'CODE' and not $expected->( $got, $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} . ")";
if ( not $ref and $got ne $expected ) {
die "Statement does not match current state in "
. "DBD::Mock::Session ($self->{name})\n"
. " got: $got\n"
. " expected: $expected";
}
}
# copy the result sets so that
# we can re-use the session
$dbh->STORE( 'mock_add_resultset' => [ @{ $current_state->{results} } ] );
sub results_for {
my ( $self, $statment ) = @_;
$self->_find_state_for($statment)->{results};
}
sub verify_bound_params {
my ( $self, $dbh, $params ) = @_;
my ( $self, $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];
}
if ( scalar @$expected != scalar @$params ) {
die "Not the same number of bound params in current state in "
. "DBD::Mock::Session ($self->{name})\n"
. " got: @{$params}"
. " expected: @{$expected}";
}
for ( 0 .. scalar @{$params} - 1 ) {
$self->_verify_bound_param( $params->[$_], $expected->[$_], $_ );
}
}
# and make sure we go to
......@@ -141,4 +138,52 @@ sub verify_bound_params {
$self->{state_index}++;
}
sub _find_state_for {
my ( $self, $statement ) = @_;
foreach ( $self->_remaining_states ) {
my $stmt = $_->{statement};
my $ref = ref($stmt);
return $_ if ( $ref eq 'Regexp' and $statement =~ /$stmt/ );
return $_ if ( $ref eq 'CODE' and $stmt->( $statement, $_ ) );
return $_ if ( not $ref and $stmt eq $statement );
}
die "Statement '$statement' not found in session ($self->{name})";
}
sub _num_states {
my $self = shift;
scalar @{ $self->{states} };
}
sub _remaining_states {
my $self = shift;
my $start_index = $self->{state_index};
my $end_index = $self->_num_states - 1;
@{ $self->{states} }[ $start_index .. $end_index ];
}
sub _verify_bound_param {
my ( $self, $got, $expected, $index ) = @_;
no warnings;
my $ref = ref $expected;
if ( $ref eq 'Regexp' and $got !~ /$expected/ ) {
die "Bound param $index do not match (using regexp) "
. "in current state in DBD::Mock::Session ($self->{name})"
. " got: $got\n"
. " expected: $expected";
}
if ( $got ne $expected ) {
die "Bound param $index do not match "
. "in current state in DBD::Mock::Session ($self->{name})\n"
. " got: $got\n"
. " expected: $expected";
}
}
1;
......@@ -55,37 +55,59 @@ sub prepare {
}
my $sth = DBI::_new_sth( $dbh, { Statement => $statement } );
$sth->trace_msg( "Preparing statement '${statement}'\n", 1 );
my %track_params = ( statement => $statement );
# If we have available resultsets seed the tracker with one
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 );
}
};
my $rs;
if ( my $all_rs = $dbh->{mock_rs} ) {
if ( my $by_name = $all_rs->{named}{$statement} ) {
if ($@) {
$dbh->DBI::set_err( 1, "Session Error: $@. Statement: $statement" );
}
# We want to copy this, because it is meant to be reusable
$rs = [ @{ $by_name->{results} } ];
if ( exists $by_name->{failure} ) {
$track_params{failure} = [ @{ $by_name->{failure} } ];
}
else {
# If we have available resultsets seed the tracker with one
my $rs;
if ( my $all_rs = $dbh->{mock_rs} ) {
if ( my $by_name = $all_rs->{named}{$statement} ) {
# We want to copy this, because it is meant to be reusable
$rs = [ @{ $by_name->{results} } ];
if ( exists $by_name->{failure} ) {
$track_params{failure} = [ @{ $by_name->{failure} } ];
}
}
else {
$rs = shift @{ $all_rs->{ordered} };
}
}
if ( ref($rs) eq 'ARRAY' && scalar( @{$rs} ) > 0 ) {
my $fields = shift @{$rs};
$track_params{return_data} = $rs;
$track_params{fields} = $fields;
$sth->STORE( NAME => $fields );
$sth->STORE( NUM_OF_FIELDS => scalar @{$fields} );
}
else {
$rs = shift @{ $all_rs->{ordered} };
$sth->trace_msg( "No return data set in DBH\n", 1 );
}
}
if ( ref($rs) eq 'ARRAY' && scalar( @{$rs} ) > 0 ) {
my $fields = shift @{$rs};
$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 );
}
# do not allow a statement handle to be created if there is no
......
......@@ -20,6 +20,10 @@ sub bind_param {
return 1;
}
sub bind_param_array {
bind_param(@_);
}
sub bind_param_inout {
my ( $sth, $param_num, $val, $max_len ) = @_;
......@@ -37,6 +41,38 @@ sub bind_param_inout {
return 1;
}
sub execute_array {
my ( $sth, $attr, @bind_values ) = @_;
# no bind values means we're relying on prior calls to bind_param_array()
# for our data
my $tracker = $sth->FETCH('mock_my_history');
# don't use a reference; there's some magic attached to it somewhere
# so make it a lovely, simple array as soon as possible
my @bound = @{ $tracker->bound_params() };
foreach my $p (@bound) {
my $result = $sth->execute( @$p );
# store the result from execute() if ArrayTupleStatus attribute is
# passed
push @{ $attr->{ArrayTupleStatus} }, $result
if (exists $attr->{ArrayTupleStatus});
}
# TODO: the docs say:
# When called in scalar context the execute_array() method returns the
# number of tuples executed, or undef if an error occurred. Like
# execute(), a successful execute_array() always returns true regardless
# of the number of tuples executed, even if it's zero. If there were any
# errors the ArrayTupleStatus array can be used to discover which tuples
# failed and with what errors.
# When called in list context the execute_array() method returns two
# scalars; $tuples is the same as calling execute_array() in scalar
# context and $rows is the number of rows affected for each tuple, if
# available or -1 if the driver cannot determine this.
# We have glossed over this...
return scalar @bound;
}
sub execute {
my ( $sth, @params ) = @_;
my $dbh = $sth->{Database};
......@@ -65,8 +101,8 @@ sub execute {
if ( my $session = $dbh->{mock_session} ) {
eval {
my $state = $session->current_state;
$session->verify_statement( $dbh, $sth->{Statement} );
$session->verify_bound_params( $dbh, $tracker->bound_params() );
$session->verify_statement( $sth->{Statement});
$session->verify_bound_params( $tracker->bound_params() );
# Load a copy of the results to return (minus the field
# names) into the tracker
......
use strict;
use Test::More tests => 59;
use Test::More tests => 55;
BEGIN {
use_ok('DBD::Mock');
......@@ -51,7 +51,7 @@ use DBI;
{
my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 });
my $session = DBD::Mock::Session->new({});
my $session = DBD::Mock::Session->new({ statement => '', results => []});
isa_ok($session, 'DBD::Mock::Session');
is($session->name(), 'Session 1', '... got the first default session name');
......@@ -64,7 +64,7 @@ use DBI;
$dbh->{mock_session} = undef;
ok(!defined($dbh->{mock_session}), '... we no longer have a session in there');
my $session2 = DBD::Mock::Session->new({});
my $session2 = DBD::Mock::Session->new({ statement => '', results => []});
isa_ok($session2, 'DBD::Mock::Session');
is($session2->name(), 'Session 2', '... got the second default session name');
......@@ -232,7 +232,7 @@ use DBI;
like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected');
eval {
DBD::Mock::Session->new('session', {}, [])
DBD::Mock::Session->new('session', { statement => '', results => [] }, [])
};
ok(defined($@), '... got an error, as expected');
like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected');
......@@ -240,10 +240,8 @@ use DBI;
}
{
my $session = DBD::Mock::Session->new('session' => {});
isa_ok($session, 'DBD::Mock::Session');
eval {
my $session = DBD::Mock::Session->new('session' => {});
$session->verify_statement(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar');
};
ok(defined($@), '... got an error, as expected');
......@@ -252,10 +250,8 @@ use DBI;
}
{
my $session = DBD::Mock::Session->new('session' => { statement => "" });
isa_ok($session, 'DBD::Mock::Session');
eval {
my $session = DBD::Mock::Session->new('session' => { statement => "" });
$session->verify_statement(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar');
};
ok(defined($@), '... got an error, as expected');
......@@ -264,11 +260,9 @@ use DBI;
}
{
my $session = DBD::Mock::Session->new('session' => { results => [] });
isa_ok($session, 'DBD::Mock::Session');
eval {
$session->verify_statement(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar');
my $session = DBD::Mock::Session->new('session' => { results => [] });
$session->verify_statement(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar');
};
ok(defined($@), '... got an error, as expected');
like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected');
......@@ -276,19 +270,15 @@ use DBI;
}
{
my $session = DBD::Mock::Session->new('session' =>
{
eval {
my $session = DBD::Mock::Session->new('session' => {
statement => [],
results => []
}
);
isa_ok($session, 'DBD::Mock::Session');
eval {
});
$session->verify_statement(DBI->connect('dbi:Mock:', '', ''), 'SELECT foo FROM bar');
};
ok(defined($@), '... got an error, as expected');
like($@, qr/^Bad \'statement\' value \'ARRAY\(0x[a-f0-9]+\)\' in current state in DBD::Mock::Session \(session\)/, '... got the error we expected');
like($@, qr/^Bad \'statement\' value \'ARRAY\(0x[a-f0-9]+\)\' in DBD::Mock::Session \(session\)/, '... got the error we expected');
}
......
use 5.006;
use strict;
use warnings;
use Test::Exception;
use Test::More tests => 7;
BEGIN {
use_ok('DBD::Mock');
use_ok('DBI');
}
my $dbh = DBI->connect( 'DBI:Mock:', '', '', { RaiseError => 1 } );
my $mock_session = DBD::Mock::Session->new(
{
statement => qr/SELECT name, id FROM person/,
results => [ [ 'name', 'id' ], [ 'Charles', 2 ], [ 'Wall', 3 ], ]
},
{
statement => qr/SELECT email FROM client/,
results => [
[ 'name', 'email' ],
[ 'Charles', 'noreply@nodomain.com' ],
[ 'Wall', 'noreply@nodomain.com' ],
]
}
);
$dbh->{mock_session} = $mock_session;
my $first_sth;
my $second_sth;
lives_ok(
sub {
$second_sth = $dbh->prepare("SELECT email FROM client");
$first_sth = $dbh->prepare("SELECT name, id FROM person");
$first_sth->execute();
$second_sth->execute();
my $row = $first_sth->fetchrow_hashref;
is( $row->{name}, 'Charles', 'First statement first column' );
is( $row->{id}, '2', 'First statement second column' );
$row = $second_sth->fetchrow_hashref;
is( $row->{name}, 'Charles', 'Second statement first column' );
is( $row->{email}, 'noreply@nodomain.com',
'Second statement second column' );
},
'Prepare two statements'
);
use strict;
use warnings;
use Test::More;
# test style cribbed from t/013_st_execute_bound_params.t
BEGIN {
use_ok('DBD::Mock');
use_ok('DBI');
}
my $sql = 'INSERT INTO staff (first_name, last_name, dept) VALUES(?, ?, ?)';
{
my $dbh = DBI->connect( 'DBI:Mock:', '', '' );
my $sth = eval { $dbh->prepare( $sql ) };
# taken from: https://metacpan.org/module/DBI#Statement-Handle-Methods
$dbh->{RaiseError} = 1; # save having to check each method call
$sth = $dbh->prepare($sql);
$sth->bind_param_array(1, [ 'John', 'Mary', 'Tim' ]);
$sth->bind_param_array(2, [ 'Booth', 'Todd', 'Robinson' ]);
# TODO: $sth->bind_param_array(3, "SALES"); # scalar will be reused for each row
eval {
$sth->execute_array( { ArrayTupleStatus => \my @tuple_status } );
};
ok( ! $@, 'Called execute_array() ok' )
or diag $@;
}
done_testing;