DBD-Mock-1.55/0000775000000000000000000000000013602403772011430 5ustar rootrootDBD-Mock-1.55/t/0000775000000000000000000000000013602403772011673 5ustar rootrootDBD-Mock-1.55/t/013_st_execute_bound_params.t0000644000175000017500000002052213602403665015567 0ustar use 5.008; use strict; use warnings; use Test::More; use DBI qw( :sql_types ); BEGIN { use_ok('DBD::Mock'); } my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; eval { $sth->bind_param( 2, 'bar' ); $sth->bind_param( 1, 'baz' ); }; ok( ! $@, 'Parameters bound to statement handle with bind_param()' ); eval { $sth->execute() }; ok( ! $@, 'Called execute() ok (empty, after bind_param calls)' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 2, 'Correct number of parameters bound (method on tracker)' ); is( $t_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); is( $t_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); my $param_attrs = $sth->{mock_my_history}->bound_param_attrs; is( scalar @{ $param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is( $param_attrs->[0], undef, "as we didn't specify any attributes/types for the first bound parameter then it should be undefined"); is( $param_attrs->[1], undef, "as we didn't specify any attributes/types for the second bound parameter then it should be undefined"); my $a_params = $sth->{mock_params}; is( scalar @{ $a_params }, 2, 'Correct number of parameters bound (attribute)' ); is( $a_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (attribute)' ); is( $a_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (attribute)' ); my $a_param_attrs = $sth->{mock_param_attrs}; is( scalar @{ $a_param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is( $a_param_attrs->[0], undef, "as we didn't specify any attributes/types for the first bound parameter then it should be undefined"); is( $a_param_attrs->[1], undef, "as we didn't specify any attributes/types for the second bound parameter then it should be undefined"); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; eval { $sth->bind_param( 2, 'bar', SQL_VARCHAR ); $sth->bind_param( 1, 'baz', { TYPE => SQL_VARCHAR } ); }; ok( ! $@, 'Parameters bound to statement handle with bind_param()' ); eval { $sth->execute() }; ok( ! $@, 'Called execute() ok (empty, after bind_param calls)' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 2, 'Correct number of parameters bound (method on tracker)' ); is( $t_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); is( $t_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); my $param_attrs = $sth->{mock_my_history}->bound_param_attrs; is( scalar @{ $param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is_deeply( $param_attrs->[0], { TYPE => SQL_VARCHAR }, "the second bound parameter attribute should match our hashref"); is( $param_attrs->[1], SQL_VARCHAR, "the first bound parameter attribute should match what we bound"); my $a_params = $sth->{mock_params}; is( scalar @{ $a_params }, 2, 'Correct number of parameters bound (attribute)' ); is( $a_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (attribute)' ); is( $a_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (attribute)' ); my $a_param_attrs = $sth->{mock_param_attrs}; is( scalar @{ $a_param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is_deeply( $a_param_attrs->[0], { TYPE => SQL_VARCHAR }, "the second bound parameter attribute should match our hashref"); is( $a_param_attrs->[1], SQL_VARCHAR, "the first bound parameter attribute should match what we bound"); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; eval { $sth->execute( 'baz', 'bar' ) }; ok( ! $@, 'Called execute() ok (empty, after bind_param calls)' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 2, 'Correct number of parameters bound (method on tracker)' ); is( $t_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); is( $t_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (method on tracker)' ); my $param_attrs = $sth->{mock_my_history}->bound_param_attrs; is( scalar @{ $param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is( $param_attrs->[0], undef, "the first bound parameter attribute should be undef as the value was bound in the execute() call"); is( $param_attrs->[1], undef, "the second bound parameter attribute should be undef as the value was bound in the execute() call"); my $a_params = $sth->{mock_params}; is( scalar @{ $a_params }, 2, 'Correct number of parameters bound (attribute)' ); is( $a_params->[0], 'baz', 'Statement handle stored bound parameter from bind_param() (attribute)' ); is( $a_params->[1], 'bar', 'Statement handle stored bound parameter from bind_param() (attribute)' ); my $a_param_attrs = $sth->{mock_param_attrs}; is( scalar @{ $a_param_attrs }, 2, 'bound_param_types length should match the number of bound parameters' ); is( $a_param_attrs->[0], undef, "the first bound parameter attribute should be undef as the value was bound in the execute() call"); is( $a_param_attrs->[1], undef, "the second bound parameter attribute should be undef as the value was bound in the execute() call"); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( 'begin dbms_output.get_line(?,?); end;' ) }; my ($bar, $baz) = ('bar', 'baz'); eval { $sth->bind_param_inout( 2, \$bar, 10 ); $sth->bind_param_inout( 1, \$baz, 100 ); }; diag $@ if $@; ok(!$@, 'Parameters bound to statement handle with bind_param_inout()' ); eval { $sth->execute() }; ok( ! $@, 'Called execute() ok (empty, after bind_param_inout calls)' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 2, 'Correct number of parameters bound (method on tracker)' ); is( $t_params->[0], \$baz, 'Statement handle stored bound parameter from bind_param_inout() (method on tracker)' ); is( $t_params->[1], \$bar, 'Statement handle stored bound parameter from bind_param_inout() (method on tracker)' ); my $a_params = $sth->{mock_params}; is( scalar @{ $a_params }, 2, 'Correct number of parameters bound (attribute)' ); is( $a_params->[0], \$baz, 'Statement handle stored bound parameter from bind_param_inout() (attribute)' ); is( $a_params->[1], \$bar, 'Statement handle stored bound parameter from bind_param_inout() (attribute)' ); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; eval { $sth->bind_param( 2, 'bar' ); $sth->bind_param( 1, 'baz', SQL_VARCHAR ); $sth->execute(); }; ok( ! $@, 'Parameters bound to statement handle with bind_param() and executed' ); eval { $sth->bind_param( 2, 'foo', { TYPE => SQL_VARCHAR } ); $sth->bind_param( 1, 'qux' ); $sth->execute(); }; ok( ! $@, 'Parameters bound to statement handle with bind_param() and executed' ); my $executionHistory = $sth->{mock_execution_history}; is_deeply( $executionHistory, [ { params => [ 'baz', 'bar' ], attrs => [ SQL_VARCHAR, undef ], }, { params => [ 'qux', 'foo' ], attrs => [ undef, { TYPE => SQL_VARCHAR } ], } ], "mock_execution_history should list the parameters and their attributes for each execution" ); } done_testing(); DBD-Mock-1.55/t/001_db_handle.t0000644000175000017500000000726513602403665012573 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test misc. attributes { my $dbh = DBI->connect('DBI:Mock:', 'user', 'pass'); isa_ok($dbh, 'DBI::db'); is($dbh->{Name}, '', '... if no db-name is given'); ok( $dbh->{AutoCommit}, '... AutoCommit DB attribute defaults to set' ); # DBI will handle attributes with 'private_', 'dbi_' or , # 'dbd_' prefixes but all others, we need to handle. $dbh->{mysql_insertid} = 10; is($dbh->{mysql_insertid}, 10, '... this attribute should be 10'); # DBI will handle these $dbh->{private_insert_id} = 15; is($dbh->{private_insert_id}, 15, '... this attribute should be 15'); $dbh->{dbi_attribute} = 2000; is($dbh->{dbi_attribute}, 2000, '... this attribute should be 2000'); $dbh->{dbd_attr} = 15_000; is($dbh->{dbd_attr}, 15_000, '... this attribute should be 15,000'); $dbh->disconnect(); } # test setting attributes post-connect { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{RaiseError} = 1; $dbh->{PrintError} = 1; $dbh->{AutoCommit} = 1; ok( $dbh->{RaiseError}, 'RaiseError DB attribute set after connect()' ); ok( $dbh->{PrintError}, 'PrintError DB attribute set after connect()' ); ok( $dbh->{AutoCommit}, 'AutoCommit DB attribute set after connect()' ); $dbh->disconnect(); } # test setting them during connect { my $dbh = DBI->connect( 'DBI:Mock:', '', '', { RaiseError => 1, PrintError => 1, AutoCommit => 1 } ); ok( $dbh->{RaiseError}, 'RaiseError DB attribute set in connect()' ); ok( $dbh->{PrintError}, 'PrintError DB attribute set in connect()' ); ok( $dbh->{AutoCommit}, 'AutoCommit DB attribute set in connect()' ); $dbh->disconnect(); } # test setting attributes with false values during connect { my $dbh = DBI->connect( 'DBI:Mock:', '', '', { RaiseError => 0, PrintError => 0, AutoCommit => 0 } ); ok( ! $dbh->{RaiseError}, 'RaiseError DB attribute unset in connect()' ); ok( ! $dbh->{PrintError}, 'PrintError DB attribute unset in connect()' ); ok( ! $dbh->{AutoCommit}, 'AutoCommit DB attribute unset in connect()' ); $dbh->disconnect(); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); is_deeply( [ $dbh->data_sources() ], [ 'DBI:Mock:' ], '... got the right data sources'); $dbh->{'mock_add_data_sources'} = 'foo'; is_deeply( [ $dbh->data_sources() ], [ 'DBI:Mock:', 'DBI:Mock:foo' ], '... got the right data sources'); } { my $dbh = DBI->connect( 'DBI:Mock:', '', '', { RaiseError => 0, PrintError => 0, PrintWarn => 0, AutoCommit => 0, } ); $dbh->{RaiseError} = 1; $dbh->{PrintError} = 1; $dbh->{PrintWarn} = 1; $dbh->{AutoCommit} = 1; ok( $dbh->{RaiseError}, 'RaiseError DB attribute set in connect() and then changed' ); ok( $dbh->{PrintError}, 'PrintError DB attribute set in connect() and then changed' ); ok( $dbh->{PrintWarn}, 'PrintWarn DB attribute set in connect() and then changed' ); ok( $dbh->{AutoCommit}, 'AutoCommit DB attribute set in connect() and then changed' ); $dbh->disconnect(); } done_testing(); DBD-Mock-1.55/t/030_st_execute_array.t0000644000175000017500000000162413602403665014234 0ustar use 5.008; 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(); DBD-Mock-1.55/t/028_bind_columns.t0000644000175000017500000000202713602403665013347 0ustar use 5.008; use strict; use warnings; use Test::More; use Test::Exception; 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/, bound_params => [ 'US', '%joe%' ], results => [ [ 'person.person_id', 'person.person_country', 'person.person_name' ], [ 1, 'AR', 'Joe Something' ], [ 2, 'UY', 'Joe That' ], [ 3, 'AR', 'Joe' ], ] } ); $dbh->{mock_session} = $mock_session; my $sth = $dbh->prepare("SELECT ..."); $sth->execute( 'US', '%joe%' ); my %row; lives_ok( sub { $sth->bind_columns( \( @row{ @{ $sth->{NAME_lc} } } ) ); }, 'Bind columns' ); ok( exists $row{'person.person_name'}, 'First column' ); ok( exists $row{'person.person_country'}, 'Second column' ); ok( exists $row{'person.person_id'}, 'Third column' ); done_testing(); DBD-Mock-1.55/t/031_setup_callbacks.t0000644000175000017500000000712513602403665014030 0ustar use 5.008; use strict; use warnings; use Test::More; use DBD::Mock; use DBD::Mock::dr; use DBI; my ( $dsn, $user, $password, $attributes ); DBD::Mock::dr::set_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); { my $dbh = DBI->connect('dbi:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 10, '... got the result we expected'); $sth->finish(); } # now let's check that we can reset the callbacks DBD::Mock::dr::set_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT bar FROM foo', results => [[ 'bar' ], [ 50 ]] }; } ); { my $dbh = DBI->connect('dbi:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); my $sth = $dbh->prepare('SELECT bar FROM foo'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, undef, "... as we have reset the callbacks this SELECT shouldn't match a result set "); $sth->finish(); } # add_connect_callbacks adds a new callback to the list DBD::Mock::dr::add_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); { my $dbh = DBI->connect('dbi:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); my $sth = $dbh->prepare('SELECT bar FROM foo'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 10, "... this should return a value as we've added its connect callback in"); $sth->finish(); } DBD::Mock::dr::set_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; } ); { my $dbh = DBI->connect('dbi:Mock:database=TEST_DATABASE;hostname=localhost', 'TEST_USER', 'TEST_PASSWORD', { customAttribute => 1 }); isa_ok($dbh, 'DBI::db'); is ( $dsn, "database=TEST_DATABASE;hostname=localhost", "The database from the DSN should be passed through to the callback" ); is ( $user, "TEST_USER", "The username should be passed through to the callback" ); is ( $password, "TEST_PASSWORD", "The password should be passed through to the callback" ); is ( ref $attributes, "HASH", "The attributes passed through to the callback should be a hash reference" ); is ( $attributes->{customAttribute}, 1, "The custom attribute should be passed through to the callback" ); } done_testing(); DBD-Mock-1.55/t/bug_117162.t0000755000175000017500000000260313602403665011703 0ustar use 5.008; use strict; use warnings; use Test::More; use Test::Exception; use DBI; use DBD::Mock; # This tests that spurious extra ->execute invocations fail with a # useful message (RT #117162). This is because there was a bug in which # DBD::Mock->verify_bound_params didn't check that the session had run # out, and on return out-of-bounds element of the state array is # accessed, causing an unhelpful error "Can't use an undefined value # as an ARRAY reference at ../lib/DBD/Mock.pm line 635." my @session = ( { 'statement' => 'INSERT INTO foo (bar) values (?);', 'results' => [], 'bound_params' => [1] }, ); my $dbh = DBI->connect('dbi:Mock:', '', '', { PrintError => 0, RaiseError => 1}); # Add just part of the expected session, such that the next step would be a 'BEGIN WORK' $dbh->{mock_session} = DBD::Mock::Session->new(@session); # now execute the steps in the session my $step = $session[0]; my $sth = $dbh->prepare($step->{statement}); ok $sth, "prepare statement"; my $params = $step->{bound_params} || []; ok $sth->execute(@$params), "execute statement"; # Session expects that to be all. So let's surprise it with another # ->execute. It should fail appropriately. throws_ok { ok $sth->execute(@$params), } qr/\QSession states exhausted, only '1' in DBD::Mock::Session\E/, "fails on executing one too many times"; done_testing(); DBD-Mock-1.55/t/016_mock_add_resultset_test.t0000664000175000017500000002022513602403665015604 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test the ability to overwrite a # hash based 'mock_add_resultset' # and have it work as expected # tests for the return value of execute below as well my $dbh = DBI->connect('dbi:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; { my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 10, '... got the result we expected'); $sth->finish(); } $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 50 ]] }; { my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); } # get it again { my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); } # and one more time for good measure { my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); } ## test regular expression for query matching $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo/, results => [ [ 'foo' ], [ 200 ] ], }; ## This one should never be used as the above one will have precedence $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo FROM/, results => [ [ 'foo' ], [ 300 ] ], }; { my $sth = $dbh->prepare('SELECT foo FROM oof'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 200, '... got the result we expected'); $sth->finish(); } ## overwrite regular expression matching $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo/, results => [ [ 'foo' ], [ 400 ] ], }; { my $sth = $dbh->prepare('SELECT foo FROM oof'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 400, '... got the result we expected'); $sth->finish(); } # check that statically assigned queries take precedence over regex matched ones { my $sth = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); my ($result) = $sth->fetchrow_array(); is($result, 50, '... got the result we expected'); $sth->finish(); } ## test the return value of execute $dbh->{mock_add_resultset} = { sql => 'INSERT INTO foo VALUES(bar)', results => [[], []] }; # check no SELECT statements { my $sth = $dbh->prepare('INSERT INTO foo VALUES(bar)'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, 1, '... got back 1 for rows with our INSERT statement'); $sth->finish(); } $dbh->{mock_add_resultset} = { sql => 'UPDATE foo SET(bar = "baz")', results => [[], [], [], [], []] }; # check no SELECT statements { my $sth = $dbh->prepare('UPDATE foo SET(bar = "baz")'); isa_ok($sth, 'DBI::st'); my $rows = $sth->execute(); is($rows, 4, '... got back 4 for rows with our UPDATE statement'); $sth->finish(); } $dbh->{mock_add_resultset} = { sql => 'SELECT x FROM y WHERE z = ?', results => [ ["x"] ], callback => sub { my @bound_params = @_; my %result = ( rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; { my $sth = $dbh->prepare('SELECT x FROM y WHERE z = ?'); isa_ok($sth, 'DBI::st'); is($sth->{NUM_OF_FIELDS}, 1, "... When we specify the fields in the results parameter then we expect an answer from NUM_OF_FIELDS before we execute the statement"); my $rows = $sth->execute(1); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); is($sth->{NUM_OF_FIELDS}, 1, "... When we specify the fields in the results parameter then we expect an answer from NUM_OF_FIELDS after we execute the statement"); my ($result) = $sth->fetchrow_array(); is($result, 32, '... got the result we expected'); $rows = $sth->execute(2); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 43, '... got the result we expected'); $rows = $sth->execute(33); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 1, '... got the result we expected'); $sth->finish(); } $dbh->{mock_add_resultset} = { sql => 'SELECT a FROM b WHERE c = ?', callback => sub { my @bound_params = @_; my %result = ( fields => [ "a" ], rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; { my $sth = $dbh->prepare('SELECT a FROM b WHERE c = ?'); isa_ok($sth, 'DBI::st'); is($sth->{NUM_OF_FIELDS}, 0 , "... When we don't specify the fields in the results parameter and we haven't activated the DefaultFieldsToUndef feature, then we expect the NUM_OF_FIELDS to be 0 before we execute the statement"); my $rows = $sth->execute(1); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); is($sth->{NUM_OF_FIELDS}, 1, "... When we don't specify the fields in the results parameter then we still expect an answer from NUM_OF_FIELDS after we've execute the statement"); my ($result) = $sth->fetchrow_array(); is($result, 32, '... got the result we expected'); $rows = $sth->execute(2); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 43, '... got the result we expected'); $rows = $sth->execute(33); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 1, '... got the result we expected'); $sth->finish(); } { # Activate the DefaultFieldsToUndef feature $DBD::Mock::DefaultFieldsToUndef = 1; my $sth = $dbh->prepare('SELECT a FROM b WHERE c = ?'); isa_ok($sth, 'DBI::st'); is($sth->{NUM_OF_FIELDS}, undef , "... When we don't specify the fields in the results parameter then we expect the NUM_OF_FIELDS to be undef before we execute the statement"); my $rows = $sth->execute(1); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); is($sth->{NUM_OF_FIELDS}, 1, "... When we don't specify the fields in the results parameter then we still expect an answer from NUM_OF_FIELDS after we've execute the statement"); my ($result) = $sth->fetchrow_array(); is($result, 32, '... got the result we expected'); $rows = $sth->execute(2); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 43, '... got the result we expected'); $rows = $sth->execute(33); is($rows, '0E0', '... got back 0E0 for rows with a SELECT statement'); ($result) = $sth->fetchrow_array(); is($result, 1, '... got the result we expected'); $sth->finish(); } done_testing(); DBD-Mock-1.55/t/014_st_execute_pass_params.t0000644000175000017500000000217013602403665015426 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; eval { $sth->execute( 'baz', 'bar' ) }; ok( ! $@, 'Called execute() ok (inline params)' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 2, 'Correct number of parameters bound (inline; method on tracker)' ); is( $t_params->[0], 'baz', 'Statement handle stored bound inline parameter (method on tracker)' ); is( $t_params->[1], 'bar', 'Statement handle stored bound inline parameter (method on tracker)' ); my $a_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $a_params }, 2, 'Correct number of parameters bound (inline; attribute)' ); is( $a_params->[0], 'baz', 'Statement handle stored bound inline parameter (attribute)' ); is( $a_params->[1], 'bar', 'Statement handle stored bound inline parameter (attribute)' ); } done_testing(); DBD-Mock-1.55/t/999_pod_coverage.t0000644000175000017500000000041513602403665013350 0ustar use 5.008; use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.04"; plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; plan tests => 1; pod_coverage_ok( 'DBD::Mock' ,{ trustme => [ qr/CLONE|driver/ ], }); DBD-Mock-1.55/t/004_misc_mock_attr.t0000644000175000017500000000442413602403665013666 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test misc. attributes of $dbh my $dbh = DBI->connect('DBI:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); $dbh->{AutoCommit} = 1; ok($dbh->{AutoCommit}, '... it handles AutoCommit as well'); $dbh->{AutoCommit} = 0; ok(! $dbh->{AutoCommit}, '... and turns off AutoCommit as well'); for (0 .. 5) { my $sth = $dbh->prepare('SELECT * FROM foo'); $sth->execute(); } is(scalar(@{$dbh->{mock_all_history}}), 6, '... we have 6 statements'); $dbh->{mock_clear_history} = 1; is(scalar(@{$dbh->{mock_all_history}}), 0, '... we have 0 statements'); # test the misc. attributes of $sth $dbh->{mock_add_resultset} = [['foo'], [1], [2], [3]]; my $SQL = 'SELECT foo FROM bar WHERE baz = ?'; # prepare a statement my $sth = $dbh->prepare($SQL); # mock_is_executed is($sth->{mock_is_executed}, 'no', '... not executed yet'); # execute and bind the param $sth->execute('test'); is($sth->{mock_is_executed}, 'yes', '... has been executed now'); # mock_my_history my $history = $sth->{mock_my_history}; ok($history, '... got something back for our history'); isa_ok($history, 'DBD::Mock::StatementTrack'); # mock_statement is($sth->{mock_statement}, $SQL, '... our statement is as expected'); # mock_fields is_deeply( $sth->{mock_fields}, [ 'foo' ], '... our fields is as expected'); # mock_records is_deeply( $sth->{mock_records}, [[1], [2], [3]], '... we have 3 records'); # mock_num_records is($sth->{mock_num_records}, 3, '... we have 3 records'); # mock_current_record_num is($sth->{mock_current_record_num}, 0, '... we are at record number 0'); # mock_is_finished is($sth->{mock_is_finished}, 'no', '... we are not yet finished'); # mock_is_depleted ok(!$sth->{mock_is_depleted}, '... nor are we depleted'); for (1 .. 3) { is(($sth->fetchrow_array())[0], $_, '... got the expected row'); is($sth->{mock_current_record_num}, $_, '... we are at record number ' . $_); } # mock_is_depleted ok($sth->{mock_is_depleted}, '... now we are depleted'); # mock_is_finished is($sth->{mock_is_finished}, 'no', '... we are not yet finished'); $sth->finish(); # mock_is_finished is($sth->{mock_is_finished}, 'yes', '... and we are now finished'); done_testing(); DBD-Mock-1.55/t/032_selectall_arrayref.t0000644000175000017500000000355513602403665014540 0ustar use 5.008; use strict; use warnings; use Test::More; use DBD::Mock; use DBI; my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); { my $rows = [ [ '1', 'european', '42' ], [ '27', 'african', '2' ], ]; $dbh->{mock_add_resultset} = { sql => 'SELECT id, type, inventory_id FROM Swallow', results => [ [ 'id', 'type', 'inventory_id' ], @{ $rows }, ] }; my $results = $dbh->selectall_arrayref( 'SELECT id, type, inventory_id FROM Swallow' ); is_deeply( $results, $rows, 'SELECTALL_ARRAYREF ref by default returns the rows from the result set' ); my $expectedResults = [ { id => 1, type => 'european', inventory_id => 42, }, { id => 27, type => 'african', inventory_id => 2, }, ]; $results = $dbh->selectall_arrayref( 'SELECT id, type, inventory_id FROM Swallow', { Slice => {} } ); is_deeply( $results, $expectedResults, 'SELECTALL_ARRAYREF ref with a slice defined should return each row as a hashref' ); $results = $dbh->selectall_arrayref( 'SELECT id, type, inventory_id FROM Swallow', { Slice => { 'id' => 1 } } ); $expectedResults = [ { id => 1, }, { id => 27, }, ]; is_deeply( $results, $expectedResults, 'SELECTALL_ARRAYREF ref with a slice defining column names should return each row as a hashref which only contains those columns' ); $expectedResults = [ [ 'european', 42 ], [ 'african', 2], ]; $results = $dbh->selectall_arrayref( 'SELECT id, type, inventory_id FROM Swallow', { Columns => [2,3] } ); is_deeply( $results, $expectedResults, 'SELECTALL_ARRAYREF ref with Columns defined should return just those columns' ); } done_testing(); DBD-Mock-1.55/t/021_DBD_Mock_Session.t0000644000175000017500000003014513602403665013733 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); } use DBI; { package Login::Test; my $MAX_LOGIN_FAILURES = 3; sub login { my ($dbh, $u, $p) = @_; # look for the right username and password my ($user_id) = $dbh->selectrow_array("SELECT user_id FROM users WHERE username = '$u' AND password = '$p'"); # if we find one, then ... if ($user_id) { # log the event and return true $dbh->do("INSERT INTO event_log (event) VALUES('User $user_id logged in')"); return 'LOGIN SUCCESSFUL'; } # if we don't find one then ... else { # see if the username exists ... my ($user_id, $login_failures) = $dbh->selectrow_array("SELECT user_id, login_failures FROM users WHERE username = '$u'"); # if we do have a username, and the password doesnt match then ... if ($user_id) { # if we have not reached the max allowable login failures then ... if ($login_failures < $MAX_LOGIN_FAILURES) { # update the login failures $dbh->do("UPDATE users SET login_failures = (login_failures + 1) WHERE user_id = $user_id"); return 'BAD PASSWORD'; } # otherwise ... else { # we must update the login failures, and lock the account $dbh->do("UPDATE users SET login_failures = (login_failures + 1), locked = 1 WHERE user_id = $user_id"); return 'USER ACCOUNT LOCKED'; } } else { return 'USERNAME NOT FOUND'; } } } } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); 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'); $dbh->{mock_session} = $session; my $fetched_session = $dbh->{mock_session}; is($fetched_session, $session, '... it is the same session we put in'); $dbh->{mock_session} = undef; ok(!defined($dbh->{mock_session}), '... we no longer have a session in there'); 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'); } { my $successful_login = DBD::Mock::Session->new('successful_login' => ( { statement => "SELECT user_id FROM users WHERE username = 'user' AND password = '****'", results => [[ 'user_id' ], [ 1 ]] }, { statement => "INSERT INTO event_log (event) VALUES('User 1 logged in')", results => [] } )); isa_ok($successful_login, 'DBD::Mock::Session'); is($successful_login->name(), 'successful_login', '... got the right name'); my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); $dbh->{mock_session} = $successful_login; is(Login::Test::login($dbh, 'user', '****'), 'LOGIN SUCCESSFUL', '... logged in successfully'); # check the reusablity # it is not reusable now eval { Login::Test::login($dbh, 'user', '****') }; ok($@, '... got the exception'); like($@, qr/Session Error\: Session states exhausted/, '... got the exception we expected'); # reset the DBD::Mock::Session object $successful_login->reset; # and it is re-usable now is(Login::Test::login($dbh, 'user', '****'), 'LOGIN SUCCESSFUL', '... logged in successfully'); } { my $bad_username = DBD::Mock::Session->new('bad_username' => ( { statement => qr/SELECT user_id FROM users WHERE username = \'.*?\' AND password = \'.*?\'/, #' results => [[ 'user_id' ], [ undef ]] }, { statement => qr/SELECT user_id, login_failures FROM users WHERE username = \'.*?\'/, #' results => [[ 'user_id', 'login_failures' ], [ undef, undef ]] } )); isa_ok($bad_username, 'DBD::Mock::Session'); is($bad_username->name(), 'bad_username', '... got the right name'); my $dbh = DBI->connect('dbi:Mock:', '', ''); $dbh->{mock_session} = $bad_username; is(Login::Test::login($dbh, 'user', '****'), 'USERNAME NOT FOUND', '... username is not found'); } { my $bad_password = DBD::Mock::Session->new('bad_password' => ( { statement => sub { $_[0] eq "SELECT user_id FROM users WHERE username = 'user' AND password = '****'" }, results => [[ 'user_id' ], [ undef]] }, { statement => sub { $_[0] eq "SELECT user_id, login_failures FROM users WHERE username = 'user'" }, results => [[ 'user_id', 'login_failures' ], [ 1, 0 ]] }, { statement => sub { $_[0] eq "UPDATE users SET login_failures = (login_failures + 1) WHERE user_id = 1" }, results => [] } )); isa_ok($bad_password, 'DBD::Mock::Session'); is($bad_password->name(), 'bad_password', '... got the right name'); my $dbh = DBI->connect('dbi:Mock:', '', ''); $dbh->{mock_session} = $bad_password; is(Login::Test::login($dbh, 'user', '****'), 'BAD PASSWORD', '... username is found, but the password is wrong'); } { my $lock_user_account = DBD::Mock::Session->new('lock_user_account' => ( { statement => "SELECT user_id FROM users WHERE username = 'user' AND password = '****'", results => [[ 'user_id' ], [ undef]] }, { statement => qr/SELECT user_id, login_failures FROM users WHERE username = \'.*?\'/, #' results => [[ 'user_id', 'login_failures' ], [ 1, 4 ]] }, { statement => sub { $_[0] eq "UPDATE users SET login_failures = (login_failures + 1), locked = 1 WHERE user_id = 1" }, results => [] } )); isa_ok($lock_user_account, 'DBD::Mock::Session'); is($lock_user_account->name(), 'lock_user_account', '... got the right name'); my $dbh = DBI->connect('dbi:Mock:', '', ''); $dbh->{mock_session} = $lock_user_account; is(Login::Test::login($dbh, 'user', '****'), 'USER ACCOUNT LOCKED', '... username is found, and the password is wrong, and the user account is now locked'); } # now check some errors { my $not_enough_statements = DBD::Mock::Session->new(( { statement => "SELECT user_id FROM users WHERE username = 'user' AND password = '****'", results => [[ 'user_id' ], [ undef]] }, { statement => qr/SELECT user_id, login_failures FROM users WHERE username = \'.*?\'/, #' results => [[ 'user_id', 'login_failures' ], [ 1, 4 ]] }, # ... removed one statement here which DBI will be looking for )); isa_ok($not_enough_statements, 'DBD::Mock::Session'); my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); $dbh->{mock_session} = $not_enough_statements; eval { Login::Test::login($dbh, 'user', '****'); }; ok(defined($@), '... got an error, as expected'); like($@, qr/Session Error\: Session states exhausted\, /, '... got the error we expected'); } { eval { DBD::Mock::Session->new() }; ok(defined($@), '... got an error, as expected'); like($@, qr/^You must specify at least one session state/, '... got the error we expected'); eval { DBD::Mock::Session->new([]) }; ok(defined($@), '... got an error, as expected'); like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected'); eval { DBD::Mock::Session->new('session') }; ok(defined($@), '... got an error, as expected'); like($@, qr/^You must specify at least one session state/, '... got the error we expected'); eval { DBD::Mock::Session->new('session', []) }; ok(defined($@), '... got an error, as expected'); like($@, qr/^You must specify session states as HASH refs/, '... got the error we expected'); eval { 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'); } { 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'); like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected'); } { 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'); like($@, qr/^Bad state \'0\' in DBD::Mock::Session \(session\)/, '... got the error we expected'); } { eval { 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'); } { eval { my $session = DBD::Mock::Session->new('session' => { statement => [], results => [] }); $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 DBD::Mock::Session \(session\)/, '... got the error we expected'); } { my $session = DBD::Mock::Session->new('session' => { statement => "SELECT foo FROM baz", 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/^Statement does not match current state in DBD::Mock::Session \(session\)/, '... got the error we expected'); } { my $session = DBD::Mock::Session->new('session' => { statement => qr/SELECT foo FROM baz/, 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/^Statement does not match current state \(with Regexp\) in DBD::Mock::Session \(session\)/, '... got the error we expected'); } { my $session = DBD::Mock::Session->new('session' => { statement => sub { 0 }, 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/^Statement does not match current state \(with CODE ref\) in DBD::Mock::Session \(session\)/, '... got the error we expected'); } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); my $session = DBD::Mock::Session->new('session' => { statement => 'Some SQL', results => [] } ); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { $dbh->disconnect; }; ok(defined($@), '... got an error, as expected'); like($@, qr/^DBH->finish called when session still has states left/, '... got the error we expected'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } done_testing(); DBD-Mock-1.55/t/015_st_fetch_records.t0000644000175000017500000000573313602403665014216 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } #use Data::Dumper qw( Dumper ); my @rs_foo = ( [ 'this', 'that' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ); my $foo_sql = 'SELECT this, that FROM foo'; my @rs_login = ( [ 'login', 'first_name', 'last_name' ], [ 'cwinters', 'Chris', 'Winters' ], [ 'bflay', 'Bobby', 'Flay' ], [ 'alincoln', 'Abe', 'Lincoln' ], ); my $login_sql = 'SELECT login, first_name, last_name FROM foo'; my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); # Seed the handle with two resultsets # the first one ordered $dbh->{mock_add_resultset} = [ @rs_foo ]; # the second one named $dbh->{mock_add_resultset} = { sql => $login_sql, results => \@rs_login }; # run the first one { my ( $sth ); eval { $sth = $dbh->prepare( $foo_sql ); $sth->execute(); }; check_resultset( $sth, [ @rs_foo ] ); } { my ( $sth ); eval { $sth = $dbh->prepare( $login_sql ); $sth->execute(); }; check_resultset( $sth, [ @rs_login ] ); } { my ( $sth ); eval { $sth = $dbh->prepare( q{INSERT INTO foo VALUES ( 'Don Corleone' )} ); $sth->execute(); }; ok( ! $sth->{Active}, '...this should not be an active handle' ); } sub check_resultset { my ( $sth, $check ) = @_; my $fields = shift @{ $check }; is( $sth->{mock_num_records}, scalar @{ $check }, 'Correct number of records reported by statement' ); is( $sth->{mock_num_rows}, scalar @{ $check }, 'Correct number of rows reported by statement' ); is( $sth->rows, scalar @{ $check }, 'Correct number of rows reported by statement' ); is( $sth->{mock_current_record_num}, 0, 'Current record number correct before fetching' ); ok( $sth->{Active}, '... this should be an active handle' ); for ( my $i = 0; $i < scalar @{ $check }; $i++ ) { my $rec_num = $i + 1; my $this_check = $check->[$i]; my $this_rec = $sth->fetchrow_arrayref; my $num_fields = scalar @{ $this_check }; is( scalar @{ $this_rec }, $num_fields, "Record $rec_num, correct number of fields ($num_fields)" ); for ( my $j = 0; $j < $num_fields; $j++ ) { my $field_num = $j + 1; is( $this_rec->[$j], $this_check->[$j], "Record $rec_num, field $field_num" ); } is( $sth->{mock_current_record_num}, $rec_num, "Record $rec_num, current record number tracked" ); if ( $rec_num == scalar @{ $check } ) { ok( $sth->{mock_is_depleted}, 'Resultset depleted properly' ); ok( ! $sth->{Active}, '...this should not be an active handle anymore' ); } else { ok( ! $sth->{mock_is_depleted}, 'Resultset not yet depleted' ); } } } done_testing(); DBD-Mock-1.55/t/011_st_execute_empty.t0000644000175000017500000000264613602403665014260 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $sql = 'SELECT * FROM foo WHERE bar = ? AND baz = ?'; { my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); my $sth = eval { $dbh->prepare( $sql ) }; ok( ! $@, 'Statement handle prepared ok' ); is( ref( $sth ), 'DBI::st', 'Statement handle returned of the proper type' ); is( $sth->{mock_my_history}->statement, $sql, 'Statement handle stores SQL (method on tracker)' ); is( $sth->{mock_statement}, $sql, 'Statement handle stores SQL (attribute)' ); is( $sth->{mock_is_executed}, 'no', 'Execute flag not set yet' ); my $rows = eval { $sth->execute() }; ok( ! $@, 'Called execute() ok (no params)' ); is($rows, '0E0', '... we got back 0E0 for num of rows'); is( $sth->{mock_is_executed}, 'yes', 'Execute flag set after execute()' ); my $t_params = $sth->{mock_my_history}->bound_params; is( scalar @{ $t_params }, 0, 'No parameters tracked (method on tracker)' ); my $a_params = $sth->{mock_params}; is( scalar @{ $a_params }, 0, 'No parameters tracked (attribute)' ); is( $sth->{mock_is_finished}, 'no', 'Finished flag not set yet' ); eval { $sth->finish }; ok( ! $@, 'Called finish() ok' ); is( $sth->{mock_is_finished}, 'yes', 'Finished flag set after finish()' ); } done_testing(); DBD-Mock-1.55/t/022_DBD_Mock_Session_bound_params.t0000644000175000017500000001345213602403665016470 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 100 ], results => [[ 'foo' ], [ 10 ]] }, { statement => 'SELECT bar FROM foo WHERE baz = ?', bound_params => [ 125 ], results => [[ 'bar' ], [ 15 ]] }, )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE baz = ?'); $sth->execute(100); my ($result) = $sth->fetchrow_array(); is($result, 10, '... got the right value'); }; ok(!$@, '... everything worked as planned'); eval { my $sth = $dbh->prepare('SELECT bar FROM foo WHERE baz = ?'); $sth->execute(125); my ($result) = $sth->fetchrow_array(); is($result, 15, '... got the right value'); }; ok(!$@, '... everything worked as planned'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 100 ], results => [[ 'foo' ], [ 10 ]] }, { statement => 'SELECT bar FROM foo WHERE baz = 125', results => [[ 'bar' ], [ 15 ]] }, { statement => 'DELETE FROM bar WHERE baz = ?', results => [[], [], []], bound_params => [ 100 ] } )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE baz = ?'); $sth->execute(100); my ($result) = $sth->fetchrow_array(); is($result, 10, '... got the right value'); }; ok(!$@, '... first state worked as planned'); eval { my $sth = $dbh->prepare('SELECT bar FROM foo WHERE baz = 125'); $sth->execute(); my ($result) = $sth->fetchrow_array(); is($result, 15, '... got the right value'); }; ok(!$@, '... second state worked as planned'); eval { my $sth = $dbh->prepare('DELETE FROM bar WHERE baz = ?'); $sth->execute(100); is($sth->rows(), 2, '... got the right number of affected rows'); }; ok(!$@, '... third state worked as planned'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } # check some errors { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 100 ], results => [[ 'foo' ], [ 10 ]] } )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE baz = ?'); $sth->execute(100, 200); my ($result) = $sth->fetchrow_array(); }; ok($@, '... everything failed as planned'); like($@, qr/Session Error\: Not the same number of bound params in current state in DBD\:\:Mock\:\:Session/, '... everything failed as planned'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 100 ], results => [[ 'foo' ], [ 10 ]] } )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE baz = ?'); $sth->execute(200); my ($result) = $sth->fetchrow_array(); }; ok($@, '... everything failed as planned'); like($@, qr/Session Error\: Bound param 0 do not match in current state in DBD\:\:Mock\:\:Session/, '... everything failed as planned'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 100 ], results => [[ 'foo' ], [ 10 ]] }, { statement => 'SELECT foo FROM bar WHERE baz = ?', bound_params => [ 125 ], results => [[ 'foo' ], [ 15 ]] }, )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; eval { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE baz = ?'); $sth->execute(100); my ($result) = $sth->fetchrow_array(); is($result, 10, '... first execute got the right value'); $sth->execute(125); ($result) = $sth->fetchrow_array(); is($result, 15, '... second execute got the right value'); }; ok(!$@, '... everything worked as planned'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } done_testing(); DBD-Mock-1.55/t/005_db_parser.t0000644000175000017500000000774613602403665012644 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } { my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{RaiseError}, 1, '... make sure RaiseError is set correctly'); # check parse sub-refs my $parser = sub { my ($sql) = @_; die "incorrect use of '*'\n" if $sql =~ /^SELECT \*/; }; eval { $dbh->{mock_add_parser} = $parser; }; ok(!$@, '... parser successfully added to dbh'); is($dbh->{mock_parser}->[0], $parser, '... the same parser is stored'); my $sth1 = eval { $dbh->prepare('SELECT myfield FROM mytable') }; isa_ok($sth1, "DBI::st"); my $sth2 = eval { $dbh->prepare( 'SELECT * FROM mytable' ) }; ok(!defined($sth2), '... we should get nothing back from here'); like($@, qr/Failed to parse statement\. Error\: incorrect use of \'\*\'\. Statement\: SELECT \* FROM mytable/, '... parser failure generated correct error'); $dbh->disconnect(); } # parser class { package MyParser; sub new { return bless {} } sub parse { my ($self, $sql) = @_; die "incorrect use of '*'\n" if $sql =~ /^SELECT \*/; } } { my $dbh = DBI->connect('DBI:Mock:', '', '', { PrintError => 1 }); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{PrintError}, 1, '... make sure PrintError is set correctly'); # check parse objects my $parser = MyParser->new(); eval { $dbh->{mock_add_parser} = $parser; }; ok(!$@, '... parser successfully added to dbh'); is($dbh->{mock_parser}->[0], $parser, '... the same parser is stored'); my $sth1 = eval { $dbh->prepare('SELECT myfield FROM mytable') }; isa_ok($sth1, "DBI::st"); { # isolate the warn handler local $SIG{__WARN__} = sub { my $msg = shift; like($msg, qr/incorrect use of \'\*\'\. Statement\: SELECT \* FROM mytable/, #' '...got the expected warning'); }; my $sth2 = eval { $dbh->prepare( 'SELECT * FROM mytable' ) }; ok(!defined($sth2), '... we should get nothing back from here'); } $dbh->disconnect(); } { # pass in a bad parser my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{RaiseError}, 1, '... make sure RaiseError is set correctly'); eval { $dbh->{mock_add_parser} = "Fail"; }; like($@, qr/Parser must be a code reference or /, '... bad parser successfully not added to dbh'); eval { $dbh->{mock_add_parser} = []; }; like($@, qr/Parser must be a code reference or /, '... bad parser successfully not added to dbh'); } { # check it with PrintError too my $dbh = DBI->connect('DBI:Mock:', '', ''); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{PrintError}, 1, '... make sure PrintError is set correctly'); { # isolate the warn handler local $SIG{__WARN__} = sub { my $msg = shift; like($msg, qr/Parser must be a code reference or /, '... bad parser successfully not added to dbh'); }; ok(!defined($dbh->{mock_add_parser} = {}), '... this returns undef too'); my $test = "Fail"; ok(!defined($dbh->{mock_add_parser} = \$test), '... this returns undef too'); } } done_testing(); DBD-Mock-1.55/t/007_mock_attribute_aliases.t0000644000175000017500000001167213602403665015413 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } { # aliasing is off my $dbh; eval { $dbh = DBI->connect('dbi:Mock:mysql', '', ''); }; ok(!$@, '... got our non-mock DB successfully'); isa_ok($dbh, 'DBI::db'); ok(!defined($dbh->{mock_attribute_aliases}), '... nothing here'); ok(!$dbh->{mock_database_name}, '... nothing here'); } # now turn it on $DBD::Mock::AttributeAliasing++; { # but without a dbname it does nothing my $dbh; eval { $dbh = DBI->connect('dbi:Mock:', '', ''); }; ok(!$@, '... got our non-mock DB successfully'); isa_ok($dbh, 'DBI::db'); ok(!defined($dbh->{mock_attribute_aliases}), '... nothing here'); ok(!$dbh->{mock_database_name}, '... nothing here'); } # now test the error eval { DBI->connect('dbi:Mock:Fail', '', ''); }; like($@, qr/Attribute aliases not available for \'Fail\'/, '... got the error we expected'); # test the MySQL mock db { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:mysql', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'mysql', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mysql_insertid}, 1, '... our alias works'); } # and test it with the lowercasing { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:MySQL', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'MySQL', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mysql_insertid}, 1, '... our alias works'); } # test the MariaDB mock db { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:mariadb', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'mariadb', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mariadb_insertid}, 1, '... our alias works'); } # and test it with the lowercasing { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:MariaDB', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'MariaDB', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mariadb_insertid}, 1, '... our alias works'); } # test the MariaDB mock db { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:host=localhost;port=3306;database=mariadb', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'mariadb', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mariadb_insertid}, 1, '... our alias works'); } # and test it with the lowercasing { my $dbh; eval { $dbh = DBI->connect('dbi:Mock:host=;database=MariaDB;port=', '', ''); }; ok(!$@, '... got our mock DB successfully'); isa_ok($dbh, 'DBI::db'); is($dbh->{mock_database_name}, 'MariaDB', '... and its the name we expected'); ok(defined($dbh->{mock_attribute_aliases}), '... got something here'); is(ref($dbh->{mock_attribute_aliases}), 'HASH', '... and its the hash we expected'); my $sth = $dbh->prepare('INSERT INTO Foo (bar) VALUES(NULL)'); isa_ok($sth, 'DBI::st'); $sth->execute(); is($dbh->{mariadb_insertid}, 1, '... our alias works'); } done_testing(); DBD-Mock-1.55/t/003_db_can_connect.t0000644000175000017500000000523313602403665013605 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test this as an exception { my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{RaiseError}, 1, '... make sure RaiseError is set correctly'); # check to see it is active in the first place ok($dbh->{Active}, '...our handle with the default settting is Active' ); ok($dbh->ping(), '...and successfuly pinged handle' ); $dbh->{mock_can_connect} = 0; # check our value is correctly set is($dbh->{mock_can_connect}, 0, '... can connect is set to 0'); # and check the side effects of that ok(!$dbh->{Active}, '...our handle is no longer Active after setting mock_can_connect'); ok(!$dbh->ping(), '...and unsuccessfuly pinged handle (good)'); my $sth = eval { $dbh->prepare( "SELECT foo FROM bar" ) }; ok($@, '... we should have an exception'); like($@, qr/No connection present/, 'Preparing statement against inactive handle throws expected exception' ); like($dbh->errstr, qr/^No connection present/, 'Preparing statement against inactive handle sets expected DBI error' ); $dbh->disconnect(); } # and now test this as a warning { my $dbh = DBI->connect('DBI:Mock:', '', '', { PrintError => 1 }); isa_ok($dbh, "DBI::db"); # check to be sure this is set, otherwise # the test wont be set up right is($dbh->{PrintError}, 1, '... make sure PrintError is set correctly'); # check to see it is active in the first place ok($dbh->{Active}, '...our handle with the default settting is Active' ); ok($dbh->ping(), '...and successfuly pinged handle' ); $dbh->{mock_can_connect} = 0; # check our value is correctly set is($dbh->{mock_can_connect}, 0, '... can connect is set to 0'); # and check the side effects of that ok(!$dbh->{Active}, '...our handle is no longer Active after setting mock_can_connect'); ok(!$dbh->ping(), '...and unsuccessfuly pinged handle (good)'); { # isolate the warn handler local $SIG{__WARN__} = sub { my $msg = shift; like($msg, qr/No connection present/, '...got the expected warning'); }; my $sth = eval { $dbh->prepare( "SELECT foo FROM bar" ) }; ok(!$@, '... we should not have an exception'); ok(!defined($sth), '... and our statement should be undefined'); } $dbh->disconnect(); } done_testing(); DBD-Mock-1.55/t/033_table_info.t0000775000175000017500000000624613602403665013005 0ustar use 5.008; use strict; use warnings; use Test::More; use DBI; if ($DBI::VERSION < 1.635) { plan skip_all => "Functionality requires DBI version 1.64 or higher"; } my $dbh = DBI->connect( 'dbi:Mock:', '', '' ); isa_ok($dbh, 'DBI::db'); my $columns = [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ]; my $fooTable = [ undef, 'testSchema', 'foo', 'TABLE', undef ]; my $barView = [ undef, 'testSchema', 'bar', 'VIEW', undef ]; my $bazTable = [ undef, 'testSchema2', 'baz', 'TABLE', 'comment' ]; my $fooResult = { TABLE_CAT => undef, TABLE_SCHEM => 'testSchema', TABLE_NAME => 'foo', TABLE_TYPE => 'TABLE', REMARKS => undef, }; my $barResult = { TABLE_CAT => undef, TABLE_SCHEM => 'testSchema', TABLE_NAME => 'bar', TABLE_TYPE => 'VIEW', REMARKS => undef, }; my $sth = $dbh->table_info( undef, 'testSchema', 'foo', undef ); is_deeply( $sth->fetchall_arrayref( {} ), [], "No mocked table info should result an empty set of results being returned" ); $dbh->{mock_add_table_info} = { cataloge => undef, schema => 'testSchema', table => 'foo', type => undef, table_info => [ $columns, $fooTable ], }; $dbh->{mock_add_table_info} = { cataloge => undef, schema => 'testSchema', table => undef, type => 'VIEW', table_info => [ $columns, $barView ], }; $dbh->{mock_add_table_info} = { cataloge => undef, schema => 'testSchema', table => undef, type => undef, table_info => [ $columns, $fooTable, $barView ], }; $sth = $dbh->table_info( undef, 'testSchema', undef, 'VIEW' ); is_deeply( $sth->fetchall_arrayref( {} ), [ $barResult ], "The matching mock results should be returned" ); $sth = $dbh->table_info( undef, 'testSchema', undef, undef ); is_deeply( $sth->fetchall_arrayref( {} ), [ $fooResult, $barResult ], "Search based up on the schema parameter only, should return in the set of results we've already defined" ); $dbh->{mock_clear_table_info} = 1; $sth = $dbh->table_info( undef, 'testSchema', 'foo', undef ); is_deeply( $sth->fetchall_arrayref( {} ), [], "Clearing the mocked table info should result in no results being returned until mock_add_table_info is used to populate the table_info again" ); $dbh->{mock_add_table_info} = { schema => '%', table_info => [ [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ], [ undef, 'testSchema', undef, undef, undef ], [ undef, 'testSchema_2', undef, undef, undef ], ], }; $sth = $dbh->table_info( undef, '%', undef, undef ); is_deeply( $sth->fetchall_arrayref( {} ), [ { TABLE_CAT => undef, TABLE_SCHEM => 'testSchema', TABLE_NAME => undef, TABLE_TYPE => undef, REMARKS => undef, }, { TABLE_CAT => undef, TABLE_SCHEM => 'testSchema_2', TABLE_NAME => undef, TABLE_TYPE => undef, REMARKS => undef, } ], "Mocking a search of schemas should return the records we've added" ); done_testing(); DBD-Mock-1.55/t/023_statement_failure.t0000664000175000017500000001326113602403665014405 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test misc. attributes { my $dbh = DBI->connect('DBI:Mock:', '', '', {RaiseError => 1, PrintError => 0}); isa_ok($dbh, 'DBI::db'); $dbh->{mock_add_resultset} = { results => DBD::Mock->NULL_RESULTSET, failure => [ 3, 'Ohlala!' ], }; my $sth = eval { $dbh->prepare('INSERT INTO bar (foo) VALUES (?)') }; ok(!$@, '$sth handle prepared correctly'); isa_ok($sth, 'DBI::st'); eval { $sth->execute('baz') }; ok( $@, '$sth handled executed and died' ); $dbh->{mock_add_resultset} = { sql => qr/SELECT/, results => DBD::Mock->NULL_RESULTSET, failure => [ 5, 'Ooops!' ], }; $sth = eval { $dbh->prepare('SELECT foo FROM bar') }; ok(!$@, '$sth handle prepared correctly'); isa_ok($sth, 'DBI::st'); eval { $sth->execute() }; ok( $@, '$sth handled executed and died' ); $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => DBD::Mock->NULL_RESULTSET, failure => [ 5, 'Ooops!' ], }; $sth = eval { $dbh->prepare('SELECT foo FROM bar') }; ok(!$@, '$sth handle prepared correctly'); isa_ok($sth, 'DBI::st'); eval { $sth->execute() }; ok( $@, '$sth handled executed and died' ); $dbh->{mock_add_resultset} = { sql => 'SELECT bar FROM foo', results => [ [ 'bar' ], [1], [2], [3], [4], [5], [6], [7], [8], [9], [10] ] }; #test new error generators $dbh->{mock_can_prepare} = 0; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 1; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_arrayref) { 1; } }; ok($@ =~ /Cannot prepare/, '$sth handle failed to prepare'); $dbh->{mock_can_prepare} = -3; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 1; my $i = 0; for (1 .. 10) { $i++; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_arrayref) { 1; } }; last if $@; } ok($@ =~ /Cannot prepare/, "$@ should contain 'Cannot prepare'"); ok($i == 4, "$i should be 4"); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 0; $dbh->{mock_can_fetch} = 1; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_arrayref) { 1; } }; ok($@ =~ /Cannot execute/, '$sth handle failed to execute'); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = -3; $dbh->{mock_can_fetch} = 1; $i = 0; for (1 .. 10) { $i++; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_arrayref) { 1; } }; last if $@; } ok($@ =~ /Cannot execute/, "$@ should contain 'Cannot execute'"); ok($i == 4, "$i should be 4"); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 0; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_arrayref) { 1; } }; ok($@ =~ /Cannot fetch/, '$sth handle failed to fetch'); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 0; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my @row = $sth->fetchrow_array) { 1; } }; ok($@ =~ /Cannot fetch/, '$sth handle failed to fetch'); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 0; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; while (my $row = $sth->fetchrow_hashref) { 1; } }; ok($@ =~ /Cannot fetch/, '$sth handle failed to fetch'); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = 0; eval { my $sth = $dbh->prepare("SELECT bar FROM foo"); $sth->execute; my @row = $sth->fetchall_arrayref; }; ok($@ =~ /Cannot fetch/, '$sth handle failed to fetch'); $dbh->{mock_can_prepare} = 1; $dbh->{mock_can_execute} = 1; $dbh->{mock_can_fetch} = -100; { my $sth; eval { $sth = $dbh->prepare("select bar from foo"); $sth->execute; }; ok(!$@, "prepare and execute should work"); isa_ok($sth, 'DBI::st'); eval { my $row = $sth->fetch }; ok(!$@, "fetch should work"); ok($dbh->{mock_can_fetch}==-99, "$dbh->{mock_can_fetch} should be -99"); eval { my $row = $sth->fetchrow_arrayref }; ok(!$@, "fetch should work"); ok($dbh->{mock_can_fetch}==-98, "$dbh->{mock_can_fetch} should be -98"); eval { my @row = $sth->fetchrow_array }; ok(!$@, "fetch should work"); ok($dbh->{mock_can_fetch}==-97, "$dbh->{mock_can_fetch} should be -97"); eval { my $row = $sth->fetchrow_hashref }; ok(!$@, "fetch should work"); ok($dbh->{mock_can_fetch}==-96, "$dbh->{mock_can_fetch} should be -96"); eval { my @rows = $sth->fetchall_arrayref }; ok(!$@, "fetch should work"); ok($dbh->{mock_can_fetch}==-95, "$dbh->{mock_can_fetch} should be -95"); } } done_testing(); DBD-Mock-1.55/t/019_mock_statement_track_iterator.t0000644000175000017500000000276613602403665017017 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); } # just test the iterator plain { my $i = DBD::Mock::StatementTrack::Iterator->new([ 1 .. 5 ]); isa_ok($i, 'DBD::Mock::StatementTrack::Iterator'); is($i->next(), 1, '... got 1'); is($i->next(), 2, '... got 2'); is($i->next(), 3, '... got 3'); is($i->next(), 4, '... got 4'); is($i->next(), 5, '... got 5'); ok(!defined($i->next()), '... got undef'); $i->reset(); is($i->next(), 1, '... got 1'); is($i->next(), 2, '... got 2'); is($i->next(), 3, '... got 3'); is($i->next(), 4, '... got 4'); is($i->next(), 5, '... got 5'); ok(!defined($i->next()), '... got undef'); } # and now test it within context my $dbh = DBI->connect('DBI:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); my $i = $dbh->{mock_all_history_iterator}; isa_ok($i, 'DBD::Mock::StatementTrack::Iterator'); ok(!defined($i->next()), '... nothing in the iterator'); $dbh->prepare("INSERT INTO nothing (nothing) VALUES('nada')"); ok(defined($i->next()), '... now something in the iterator (which is what we want)'); $dbh->prepare("INSERT INTO nothing (nothing) VALUES('nada')"); my $next = $i->next(); ok(defined($next), '... something in the iterator'); isa_ok($next, 'DBD::Mock::StatementTrack'); is($next->statement, "INSERT INTO nothing (nothing) VALUES('nada')", '... its our old insert statement too'); ok(!defined($i->next()), '... now nothing in the iterator'); done_testing(); DBD-Mock-1.55/t/bug_082243.t0000644000175000017500000000165213602403665011704 0ustar # This is test for bug rt#82243 - Bug with Regex in DBD::Mock::Session use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } { my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, 'DBI::db'); my $session = DBD::Mock::Session->new(( { statement => 'SELECT bar FROM foo WHERE baz = ?', bound_params => [ qr/^125$/ ], results => [[ 'bar' ], [ 15 ]] }, )); isa_ok($session, 'DBD::Mock::Session'); $dbh->{mock_session} = $session; my $sth = $dbh->prepare('SELECT bar FROM foo WHERE baz = ?'); $sth->execute(125); my ($result) = $sth->fetchrow_array(); is($result, 15, 'Regex matching on bound_params should work as expected.'); # Shuts up warning when object is destroyed undef $dbh->{mock_session}; } done_testing(); DBD-Mock-1.55/t/017_st_can_connect.t0000644000175000017500000000451313602403665013653 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $dbh = DBI->connect('DBI:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($dbh, "DBI::db"); ok($dbh->{RaiseError}, '... RaiseError is set correctly'); ok(! $dbh->{PrintError}, '... PrintError is set correctly'); my $sth_exec = $dbh->prepare('SELECT foo FROM bar'); isa_ok($sth_exec, "DBI::st"); # turn off the handle between the prepare and execute... $dbh->{mock_can_connect} = 0; # check our value is correctly set is($dbh->{mock_can_connect}, 0, '... can connect is set to 0'); # and check the side effects of that ok(!$dbh->{Active}, '... the handle is not Active'); ok(!$dbh->ping(), '... and ping returns false'); # now try to execute it eval { $sth_exec->execute() }; ok($@, '... we got an exception'); like($@, qr/No connection present/, '... we got the expected execption'); # turn off the database between execute and fetch $dbh->{mock_can_connect} = 1; # check our value is correctly set is($dbh->{mock_can_connect}, 1, '... can connect is set to 1'); # and check the side effects of that ok($dbh->{Active}, '... the handle is Active'); ok($dbh->ping(), '... and ping returns true'); $dbh->{mock_add_resultset} = [[ qw(foo bar ) ], # column headers [ qw(this that ) ], # first row values [ qw(never seen) ]]; # second row values my $sth_fetch = $dbh->prepare('SELECT foo, bar FROM baz'); isa_ok($sth_fetch, "DBI::st"); eval { $sth_fetch->execute() }; ok(!$@, '... executed without exception'); my $row = eval { $sth_fetch->fetchrow_arrayref() }; ok(!$@, '... the first row was returned without execption'); is_deeply($row, [ qw(this that) ], '... we got back the expected data in the first row'); # now turn off the database $dbh->{mock_can_connect} = 0; # check our value is correctly set is($dbh->{mock_can_connect}, 0, '... can connect is set to 0'); # and check the side effects of that ok(!$dbh->{Active}, '... the handle is not Active'); ok(!$dbh->ping(), '... and ping returns false'); $row = eval { $sth_fetch->fetchrow_arrayref() }; ok($@, '... we got the exception'); like($sth_fetch->errstr, qr/^No connection present/, '... fetching row against inactive db throws expected exception' ); done_testing(); DBD-Mock-1.55/t/012_st_handle.t0000644000175000017500000000313313602403665012624 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test misc. attributes { my $dbh = DBI->connect('DBI:Mock:', 'user', 'pass'); isa_ok($dbh, 'DBI::db'); $dbh->{mock_add_resultset} = [[ 'Foo', 'Bar', 'Baz' ],[ 1, 1, 1 ]]; my $sth = eval { $dbh->prepare('SELECT Foo, Bar, Baz FROM FooBarBaz') }; ok(!$@, '... $sth handle prepared ok'); isa_ok($sth, 'DBI::st'); is($sth->{Statement}, 'SELECT Foo, Bar, Baz FROM FooBarBaz', '... got the right statement'); is($sth->{Database}, $dbh, '... got the right Database handle'); is($sth->{NUM_OF_FIELDS}, 3, '... got the right number of fields'); is($sth->{NUM_OF_PARAMS}, 0, '... got the right number of params'); is_deeply( $sth->{NAME}, [ 'Foo', 'Bar', 'Baz' ], '... got the right NAME attributes'); is_deeply( $sth->{NAME_lc}, [ 'foo', 'bar', 'baz' ], '... got the right NAME_lc attributes'); is_deeply( $sth->{NAME_uc}, [ 'FOO', 'BAR', 'BAZ' ], '... got the right NAME_uc attributes'); is_deeply( $sth->{NAME_hash}, { Foo => 0, Bar => 1, Baz => 2 }, '... got the right NAME_hash attributes'); is_deeply( $sth->{NAME_hash_lc}, { foo => 0, bar => 1, baz => 2 }, '... got the right NAME_hash_lc attributes'); is_deeply( $sth->{NAME_hash_uc}, { FOO => 0, BAR => 1, BAZ => 2 }, '... got the right NAME_hash_uc attributes'); } done_testing(); DBD-Mock-1.55/t/bug_015602.t0000644000175000017500000000147513602403665011702 0ustar # This is RT #15602 # The bug that was reported did not appear, but it did expose # another bug with consecutive executes() use 5.008; use strict; use warnings; use Test::More; use_ok('DBI'); my $dbh = DBI->connect( 'dbi:Mock:', '', '', { PrintError => 0 } ); isa_ok($dbh, 'DBI::db'); my $SQL = "select foo from bar where a = ? and b = ?"; my $s = DBD::Mock::Session->new("bugdemo", { statement=> $SQL, bound_params=>[1,2], results=>[['foo'],[1]] }, { statement=> $SQL, bound_params=>[3,4], results=>[['foo'],[1]], }, ); $dbh->{mock_session} = $s; my $sth=$dbh->prepare($SQL); eval { ok( !$sth->execute(3,4), "Bind failed" ); ok( $sth->execute(1,2), "Bind passed" ); }; # Shuts up warning when object is destroyed undef $dbh->{mock_session}; done_testing(); DBD-Mock-1.55/t/020_db_pool.t0000644000175000017500000000370413602403665012304 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok( 'DBD::Mock' => qw(Pool) ); use_ok('DBI'); } # check that the pool works { my $dbh = DBI->connect("DBI:Mock:", '', '', {RaiseError => 1 }); isa_ok($dbh, 'DBD::Mock::Pool::db'); my $dbh2 = DBI->connect("DBI:Mock:", '', '', {RaiseError => 1 }); isa_ok($dbh2, 'DBD::Mock::Pool::db'); is($dbh, $dbh2, '... these handles should be the same'); ok($dbh->disconnect(), '... this will not actually do anything just return true'); ok($dbh2->disconnect(), '... this will not actually do anything just return true'); } # check that the pool holds result sets # in an scope indepenent manner { # set up handle from pool my $dbh = DBI->connect("DBI:Mock:", '', '', {RaiseError => 1 }); isa_ok($dbh, 'DBD::Mock::Pool::db'); $dbh->{mock_add_resultset} = [[ 'foo', 'bar', 'baz' ], [ 1, 2, 3 ]]; ok($dbh->disconnect(), '... not really disconnecting, just returning true'); } { # execute a statement, and expect the results my $dbh = DBI->connect("DBI:Mock:", '', '', {RaiseError => 1 }); isa_ok($dbh, 'DBD::Mock::Pool::db'); my $sth = $dbh->prepare("SELECT foo, bar, baz FROM whatever"); $sth->execute(); is_deeply( $sth->fetchrow_arrayref(), [ 1, 2, 3 ], '... got our row correctly' ); $sth->finish(); ok($dbh->disconnect(), '... not really disconnecting, just returning true'); } { # check our statement history my $dbh = DBI->connect("DBI:Mock:", '', ''); isa_ok($dbh, 'DBD::Mock::Pool::db'); my $history = $dbh->{mock_all_history}; is(scalar @{$history}, 1, '... we executed 1 statement'); is( $history->[0]->statement(), "SELECT foo, bar, baz FROM whatever", '... this the statement we executed'); ok($dbh->disconnect(), '... not really disconnecting, just returning true'); } done_testing(); DBD-Mock-1.55/t/008_db_connect_cached.t0000644000175000017500000000067613602403665014266 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } # test that connect cached works as expected. { my $dbh = DBI->connect_cached('DBI:Mock:', 'user', 'pass'); isa_ok($dbh, 'DBI::db'); my $dbh2 = DBI->connect_cached('DBI:Mock:', 'user', 'pass'); isa_ok($dbh2, 'DBI::db'); is($dbh, $dbh2, '.. these should be the same handles'); } done_testing(); DBD-Mock-1.55/t/002_dr_handle.t0000644000175000017500000000536413602403665012612 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $drh = DBI->install_driver("Mock"); isa_ok($drh, 'DBI::dr'); is($drh->{Name}, 'Mock', '... got the right name'); is($drh->{Version}, $DBD::Mock::VERSION, '... got the right version'); is($drh->{Attribution}, 'DBD Mock driver by Chris Winters & Stevan Little (orig. from Tim Bunce)', '... got the right attribution'); # make sure we always get the same one back { my $drh2 = DBI->install_driver("Mock"); isa_ok($drh2, 'DBI::dr'); is($drh, $drh2, '... got the same driver'); } is_deeply( [ $drh->data_sources() ], [ 'DBI:Mock:' ], '... got the expected data sources'); $drh->{mock_data_sources} = [ 'test', 'DBI:Mock:mysql' ]; is_deeply( [ $drh->data_sources() ], [ 'DBI:Mock:test', 'DBI:Mock:mysql' ], '... got the expected data sources'); $drh->{mock_add_data_sources} = 'foo'; is_deeply( [ $drh->data_sources() ], [ 'DBI:Mock:test', 'DBI:Mock:mysql', 'DBI:Mock:foo' ], '... got the expected data sources'); { # connect through the driver handle my $dbh = $drh->connect(); isa_ok($dbh, 'DBI::db'); is($dbh->{Driver}, $drh, '... our driver is as we expect'); $dbh->disconnect(); } { # check the mock_connect_fail attribute is($drh->{mock_connect_fail}, 0, '... the default is set not to fail'); # make sure the this only affects the initial connect my $_dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); isa_ok($_dbh, 'DBI::db'); # now no more connections $drh->{mock_connect_fail} = 1; is($drh->{mock_connect_fail}, 1, '... we are set to fail'); eval { DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); }; ok($@, '... could not connect (as expected)'); like($@, qr/^DBI connect\(\'\'\,\'\'\,\.\.\.\) failed\: Could not connect to mock database/, #' '... got the error we expected too'); # make sure the handle we created before the change works eval { $_dbh->prepare( "SELECT foo FROM bar" ) }; ok(!$@, '... we should not have an exception here'); $drh->{mock_connect_fail} = 0; is($drh->{'mock_connect_fail'}, 0, '... we are set not to fail'); my $dbh; eval { $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1, PrintError => 0 }); }; ok(!$@, '... could connect (as expected)'); isa_ok($dbh, 'DBI::db'); } { # check other attributes $drh->{mock_nothing} = 100; ok(!defined($drh->{mock_nothing}), '... we only support our attributes'); $drh->{nothing} = 100; ok(!defined($drh->{nothing}), '... we only support our attributes'); } done_testing(); DBD-Mock-1.55/t/025_mock_last_insert_id.t0000644000175000017500000000312613602403665014705 0ustar use 5.008; use strict; use warnings; use Test::More; use DBI; my $dbh = DBI->connect( 'DBI:Mock:', '', '' ) || die "Cannot create handle: $DBI::errstr\n"; $dbh->{mock_start_insert_id} = ['Foo', 123]; $dbh->{mock_start_insert_id} = ['Baz', 345]; { my $sth = $dbh->prepare('INSERT INTO Foo (foo, bar) values (?, ?)'); $sth->execute(15, 17); is($dbh->{mock_last_insert_id}, 123, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 123, '... got the right insert id from last_insert_id'); $sth->execute(16, 18); is($dbh->{mock_last_insert_id}, 124, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 124, '... got the right insert id from last_insert_id'); $sth->execute(19, 34); is($dbh->{mock_last_insert_id}, 125, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 125, '... got the right insert id from last_insert_id'); } { my $sth = $dbh->prepare('INSERT IGNORE INTO Baz (foo, bar) values (?, ?)'); $sth->execute(90, 41); is($dbh->{mock_last_insert_id}, 345, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 345, '... got the right insert id from last_insert_id'); $sth->execute(32, 71); is($dbh->{mock_last_insert_id}, 346, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 346, '... got the right insert id from last_insert_id'); $sth->execute(77, 42); is($dbh->{mock_last_insert_id}, 347, '... got the right insert id'); is($dbh->last_insert_id((undef)x4), 347, '... got the right insert id from last_insert_id'); } done_testing(); DBD-Mock-1.55/t/bug_066815.t0000755000175000017500000000742013602403665011715 0ustar use 5.008; use strict; use warnings; use Test::More; use Test::Exception; use DBI; use DBD::Mock; # This test is designed to expose the bug found in the DBD::Mock # methods begin_work, commit and rollback (RT #66815), where a failing # ->prepare invocation (returning nothing) is not detected and the # undefined value resulting is used anyway. In this test, as in the # example found in the wild, the failure is triggered by exhaustion of # the session states. # # This is a list of sessions designed to engineer the right condition # to trigger the bug. They all start with a dummy statement (so that # there are at least two states) then the final statement is removed # before it is passed to DBD::Mock::Session->new (which requires at # least one state). The final statements are 'BEGIN WORK', 'COMMIT' # and 'ROLLBACK', respectively. # # Hence, when the test tries to invoke the final state, the session # will have run out and DBD::Mock->verify_statement will cause the # prepare method to fail. my @cases = ( 'begin_work' => [ { statement => 'SELECT something FROM somewhere', results => [], }, { statement => 'BEGIN WORK', results => [], }, ], 'commit' => [ { statement => 'SELECT something FROM somewhere', results => [], }, { statement => 'BEGIN WORK', results => [], }, { statement => 'INSERT INTO foo (bar) VALUES (?);', results => [], bound_params => [1], }, { statement => 'COMMIT', results => [], }, ], 'rollback' => [ { statement => 'SELECT something FROM somewhere', results => [], }, { statement => 'BEGIN WORK', results => [], }, { statement => 'INSERT INTO foo (bar) VALUES (?);', results => [], bound_params => [1], }, { statement => 'ROLLBACK', results => [], }, ], ); while(@cases) { my ($name, $states) = splice @cases, 0, 2; my $case_name = "case $name"; my $dbh = DBI->connect('dbi:Mock:', '', '', { PrintError => 0, RaiseError => 1 }); # Add all but the last state of the expected session my $missing_state = pop @$states; my $num_states = @$states; $dbh->{mock_session} = DBD::Mock::Session->new($name => @$states); # Execute the initial dummy statement. my $state = $states->[0]; my $sth = $dbh->prepare($state->{statement}); ok $sth, "$case_name: prepare statement"; ok $sth->execute(), "$case_name: execute statement"; # Now try and do the next steps in @session, but using the # appropriate transaction methods directly. This should fail when # the session is exhausted with a useful message. (The original # bug meant that the message got clobbered by "Can't call method # 'execute' on an undefined value".) throws_ok { # This stlibatement is always the same. ok $dbh->begin_work, "$case_name: start transaction"; my $state = $states->[2]; my $sth = $dbh->prepare($state->{statement}); ok $sth, "$case_name: prepare statement"; ok $sth->execute(@{$state->{bound_params}}), "$case_name: execute statement"; # get the final operation from the session my $operation = lc $missing_state->{statement}; ok $dbh->$operation, "$case_name: $operation transaction"; } qr/\QSession states exhausted, only '$num_states' in DBD::Mock::Session\E/; } done_testing(); DBD-Mock-1.55/t/029_multiple_prepare_statements.t0000644000175000017500000000254413602403665016520 0ustar use 5.008; use strict; use warnings; use Test::More; use Test::Exception; 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' ); done_testing(); DBD-Mock-1.55/t/998_pod.t0000644000175000017500000000025213602403665011473 0ustar use 5.008; use strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); DBD-Mock-1.55/t/bug_071438.t0000644000175000017500000000232213602403665011703 0ustar # this is bug RT #71438 use 5.008; use strict; use warnings; use Test::More; use DBI; my $dbh = DBI->connect('dbi:Mock:', '', '', { PrintError => 0, RaiseError => 1}); my $query = 'SELECT foo, bar FROM baz WHERE id=?'; my @session = ( { statement => $query, results => [ ['foo', 'bar'], [1, 'test1'], [2, 'test2'] ], bound_params => [ 1 ], }, { statement => $query, results => [ ['abc', 'xyz'], [7, 'test7'], [8, 'test8'] ], bound_params => [ 2 ], }, ); $dbh->{mock_session} = DBD::Mock::Session->new(@session); # First query my $sth = $dbh->prepare($query); $sth->execute(1); is_deeply( $sth->fetchrow_hashref(), {foo => 1, bar => 'test1'} ); is_deeply( $sth->fetchrow_hashref(), {foo => 2, bar => 'test2'} ); is_deeply( $sth->fetchrow_hashref(), undef ); # Second query $sth = $dbh->prepare($query); $sth->execute(2); is_deeply( $sth->fetchrow_hashref(), {abc => 7, xyz => 'test7'} ); is_deeply( $sth->fetchrow_hashref(), {abc => 8, xyz => 'test8'} ); is_deeply( $sth->fetchrow_hashref(), undef ); done_testing(); DBD-Mock-1.55/t/027_named_parameters.t0000644000175000017500000000332513602403665014203 0ustar use 5.008; use strict; use warnings; use Test::More; 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' ); done_testing(); DBD-Mock-1.55/t/000_basic.t0000644000175000017500000000027213602403665011742 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok( 'DBD::Mock' ); } if ( $ENV{REPORT_TEST_ENVIRONMENT} ) { warn "\n\nperl $] ($^O)\n\n"; } done_testing(); DBD-Mock-1.55/t/024_selcol_fetchhash.t0000644000175000017500000000521713602403665014171 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $swallow_sql = "SELECT id, type, inventory_id, species FROM birds WHERE species='swallow'"; my $items_sql = "SELECT id, name, weight FROM items"; my @resultList = ( { sql => $swallow_sql, results => [ [ 'id', 'type', 'inventory_id' ], [ '1', 'european', '42' ], [ '27', 'african', '2' ], ], }, { sql => $items_sql, results => [ [ 'id', 'name', 'weight' ], [ '2', 'coconuts', 'fairly hefty' ], [ '42', 'not coconuts', 'pretty light' ], ], }, ); my $coco_hash = { 'id' => '2', 'name' => 'coconuts', 'weight' => 'fairly hefty', }; my $not_coco_hash = { 'id' => '42', 'name' => 'not coconuts', 'weight' => 'pretty light', }; my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); { my $res; foreach $res (@resultList) { $dbh->{mock_add_resultset} = $res; } } { my $res; my @expected = ('1','27'); eval { $res = $dbh->selectcol_arrayref($swallow_sql); }; isa_ok(\$res, "REF"); isa_ok($res, "ARRAY"); is_deeply($res, \@expected, "Checking if selectcol_arrayref works."); } { my %expected = (1 => 'european', 27 => 'african'); my $res = eval { $dbh->selectcol_arrayref($swallow_sql, {Columns=>[1, 2]}) }; is_deeply( { @{$res || []} }, \%expected, 'Checking if selectcol_arrayref works with Columns attribute' ); } is_deeply( $dbh->selectall_hashref($items_sql, 'id', "Checking selectall_hashref with named key."), { '2' => $coco_hash, '42' => $not_coco_hash, }, '... selectall_hashref with named key'); is_deeply( $dbh->selectall_hashref($items_sql, 2, "Checking selectall_hashref with numeric key."), { 'coconuts' => $coco_hash, 'not coconuts' => $not_coco_hash, }, '... selectall_hashref with numeric key'); is_deeply( $dbh->selectall_hashref($items_sql, ['id', 'name'], "Checking selectall_hashref with array of named keys."), { 2 => { 'coconuts' => $coco_hash, }, 42 => { 'not coconuts' => $not_coco_hash }, }, '... selectall_hashref with array of named keys'); is_deeply( $dbh->selectall_hashref($items_sql, [1, 2], "Checking selectall_hashref with array of numeric keys."), { 2 => { 'coconuts' => $coco_hash, }, 42 => { 'not coconuts' => $not_coco_hash }, }, '... selectall_hashref with array of numeric keys'); is_deeply( $dbh->selectall_hashref($items_sql, [], "Checking selectall_hashref with empty array of keys."), { %{$not_coco_hash} }, '... selectall_hashref with empty array of keys'); done_testing(); DBD-Mock-1.55/t/026_st_bind_col.t0000644000175000017500000000357413602403665013160 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{mock_add_resultset} = [ [ 'id', 'type', 'inventory_id' ], [ '1', 'european', '42' ], [ '27', 'african', '2' ], ]; my $sth = $dbh->prepare( 'SELECT id, type, inventory_id FROM Swallow' ); $sth->execute(); { my ($id, $type, $inventory_id); $sth->bind_col( 1, \$id ); $sth->bind_col( 2, \$type ); $sth->bind_col( 3, \$inventory_id ); ok( $sth->fetch(), 'fetch() returned data' ); is( $id, 1, 'bind_col to $id == 1' ); is( $type, 'european', 'bind_col to $type == "european"' ); is( $inventory_id, 42, 'bind_col to $inventory_id == 42' ); } { my %hash; $sth->bind_columns( \( @hash{ qw( id type inventory_id ) } ) ); ok( $sth->fetch(), 'fetch() returned data' ); is( $hash{id}, 27, 'bind_columns with hash, id == 1' ); is( $hash{type}, 'african', 'bind_columns with hash, type == "african"' ); is( $hash{inventory_id}, 2, 'bind_columns with hash, inventory_id == 2' ); } { ok( ! $sth->fetchrow_arrayref(), 'fetchrow_arrayref returns false after data is exhausted, even with bound columns' ); } { $dbh->{mock_clear_history} = 1; my @rows = ( [ '1', 'european', '42' ], [ '27', 'african', '2' ], ); $dbh->{mock_add_resultset} = [ [ 'id', 'type', 'inventory_id' ], @rows, ]; my $results = $dbh->selectall_arrayref( 'SELECT id, type, inventory_id FROM Swallow' ); is_deeply( $results, \@rows, 'bind_col implementation does not break selectall_* methods' ); } done_testing(); DBD-Mock-1.55/t/006_prepare_cached.t0000644000175000017500000000211513602403665013612 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); use_ok('DBI'); } my $dbh = DBI->connect('dbi:Mock:', '', ''); isa_ok($dbh, 'DBI::db'); foreach my $i ( 1 .. 2 ) { my $sth = $dbh->prepare('SELECT foo FROM bar WHERE x = ?'); $sth->execute($i); my $history = $dbh->{mock_all_history}; is(scalar(@{$history}), $i, "... have $i statement executions"); } $dbh->{mock_clear_history} = 1; my $history = $dbh->{mock_all_history}; is(scalar(@{$history}), 0, '... the history has been is cleared'); foreach my $i ( 1 .. 2 ) { my $sth = $dbh->prepare_cached('SELECT foo FROM bar WHERE x = ?'); $sth->execute($i); my $history = $dbh->{mock_all_history}; is(scalar(@{$history}), $i, "... have $i statement executions"); } my $st_track = $dbh->{mock_all_history}->[0]; isa_ok($st_track, 'DBD::Mock::StatementTrack'); is($st_track->statement, 'SELECT foo FROM bar WHERE x = ?', '... our statements match'); my $params = $st_track->bound_params; is(scalar(@{$params}), 1, '... got the expected amount of params'); done_testing(); DBD-Mock-1.55/t/018_mock_statement_track.t0000644000175000017500000001353513602403665015101 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBD::Mock'); } { # check the available methods can_ok("DBD::Mock::StatementTrack", 'new'); my $st_track = DBD::Mock::StatementTrack->new(); isa_ok($st_track, 'DBD::Mock::StatementTrack'); can_ok($st_track, 'num_fields'); can_ok($st_track, 'num_params'); can_ok($st_track, 'bound_param'); can_ok($st_track, 'bound_param_trailing'); can_ok($st_track, 'is_active'); can_ok($st_track, 'is_finished'); can_ok($st_track, 'mark_executed'); can_ok($st_track, 'next_record'); can_ok($st_track, 'is_depleted'); can_ok($st_track, 'to_string'); can_ok($st_track, 'is_executed'); can_ok($st_track, 'statement'); can_ok($st_track, 'current_record_num'); can_ok($st_track, 'return_data'); can_ok($st_track, 'fields'); can_ok($st_track, 'bound_params'); } { # check the default state my $st_track = DBD::Mock::StatementTrack->new(); isa_ok($st_track, 'DBD::Mock::StatementTrack'); is($st_track->num_fields(), 0, '... we have no fields in the default'); is_deeply($st_track->fields(), [], '... we have no fields in the default'); is($st_track->num_params(), 0, '... we have no bound params in the default'); is_deeply($st_track->bound_params(), [], '... we have no bound params in the default'); is_deeply($st_track->return_data(), [], '... we have no return data in the default'); is($st_track->current_record_num(), 0, '... our current record num is 0 in the default'); is($st_track->statement(), '', '... our statement is a blank string in the default'); is($st_track->is_executed(), 'no', '... our statement is not executed in the default'); ok($st_track->is_depleted(), '... the default state is depleted'); ok(!defined($st_track->next_record()), '... the default state has no next record since it is depleted'); is($st_track->is_finished(), 'no', '... our statement is not finished in the default'); is($st_track->is_active(), 0, '... the default state is not active'); } { # check a pre-defined state my %params = ( return_data => [ [1, 1, 1], [2, 2, 2], [3, 3, 3] ], fields => [ 'foo', 'bar', 'baz' ], bound_params => [ 'baz' ], statement => 'SELECT foo FROM bar WHERE baz = ?' ); my $st_track = DBD::Mock::StatementTrack->new(%params); isa_ok($st_track, 'DBD::Mock::StatementTrack'); is($st_track->num_fields(), 3, '... we have the expected num of fields'); is_deeply($st_track->fields(), $params{fields}, '... we have the expected fields'); is($st_track->num_params(), 1, '... we have the expected num of bound params'); is_deeply($st_track->bound_params(), $params{bound_params}, '... we have the expected bound params'); is_deeply($st_track->return_data(), $params{return_data}, '... we have the expected return data'); is($st_track->current_record_num(), 0, '... our current record num is 0 in the default'); is($st_track->statement(), $params{statement}, '... our statement as expected '); is($st_track->is_executed(), 'no', '... our statement is not executed'); ok(!$st_track->is_depleted(), '... the state is not depleted'); is($st_track->is_finished(), 'no', '... our statement is not finished'); is($st_track->is_active(), 0, '... the default state is active'); # now lets alter that state # and make sure changes reflect is_deeply( $st_track->bound_param(2, 'foo'), [ 'baz', 'foo' ], '... we have the expected bound params'); $st_track->bound_param_trailing('bar', 'foobar'); is_deeply( $st_track->bound_params(), [ 'baz', 'foo', 'bar', 'foobar' ], '... we have the expected bound params'); is($st_track->num_params(), 4, '... we have the expected num of bound params'); { my $old_SQL = $st_track->statement(); my $SQL = 'INSERT INTO foo (foo, bar, baz) VALUE(1, 2, 3)'; $st_track->statement($SQL); is($st_track->statement(), $SQL, '... our statement as expected '); is($st_track->is_active(), 0, '... with an INSERT we are not considered active'); $st_track->statement($old_SQL); is($st_track->statement(), $old_SQL, '... restore our statement'); } $st_track->mark_executed(); is($st_track->is_executed(), 'yes', '... our statement is now executed'); is($st_track->current_record_num(), 0, '... our current record num is 0'); is($st_track->is_active(), 1, '... we are active now that we are executed'); for (1 .. 3) { ok(!$st_track->is_depleted(), '... the state is not depleted'); is_deeply( $st_track->next_record(), [ $_, $_, $_ ], '... got the next record as expected'); is($st_track->current_record_num(), $_, '... our current record num is now ' . $_); } ok(!defined($st_track->next_record()), '... no more records'); ok($st_track->is_depleted(), '... we are now depleted'); is($st_track->is_active(), 0, '... we are no longer active now that we are depleted'); is($st_track->is_finished(), 'no', '... passing in nothing just returns the value'); $st_track->is_finished('yes'); is($st_track->is_finished(), 'yes', '... our statement is now finished'); $st_track->is_finished('nothing'); is($st_track->is_finished(), 'no', '... our statement is no longer finished'); } done_testing(); DBD-Mock-1.55/t/010_rollback.t0000755000175000017500000000516413602403665012463 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBI'); } my $dbh = DBI->connect( 'dbi:Mock:', '', '' ); isa_ok($dbh, 'DBI::db'); $dbh->{PrintError} = 0; ################################################################################ $dbh->{AutoCommit} = 0; ok( $dbh->{AutoCommit} == 0, "AutoCommit is off" ); ok( $dbh->commit, 'commit() returns true' ); ok( $dbh->rollback, 'rollback() returns true' ); ok( !defined $dbh->begin_work, "begin_work() fails if AutoCommit is off" ); is( $DBI::errstr, 'AutoCommit is off, you are already within a transaction'); my $history = $dbh->{mock_all_history}; ok( @$history == 2, "Correct number of statements" ); is( $history->[0]->statement, 'COMMIT' ); ok( @{$history->[0]->bound_params} == 0, 'No parameters' ); is( $history->[1]->statement, 'ROLLBACK' ); ok( @{$history->[1]->bound_params} == 0, 'No parameters' ); ok( $dbh->{AutoCommit} == 0, "AutoCommit is still off" ); $dbh->{mock_clear_history} = 1; ################################################################################ $dbh->{AutoCommit} = 1; ok( $dbh->{AutoCommit} == 1, "AutoCommit is on" ); ok( !defined $dbh->commit, "Commit returns false" ); is( $DBI::errstr, "commit ineffective with AutoCommit" ); ok( !defined $dbh->rollback, "Rollback returns false" ); is( $DBI::errstr, "rollback ineffective with AutoCommit" ); ok( $dbh->{AutoCommit} == 1, "AutoCommit is still on" ); $history = $dbh->{mock_all_history}; ok( @$history == 0, "Correct number of statements" ); $dbh->{mock_clear_history} = 1; ################################################################################ $dbh->{AutoCommit} = 1; ok( $dbh->{AutoCommit} == 1, "AutoCommit is on" ); ok( $dbh->begin_work, 'begin_work() returns true' ); ok( $dbh->{AutoCommit} == 0, "AutoCommit is now off" ); ok( $dbh->rollback, 'rollback() returns true' ); ok( $dbh->{AutoCommit} == 1, "AutoCommit is back on" ); ok( $dbh->begin_work, 'begin_work() returns true' ); ok( $dbh->{AutoCommit} == 0, "AutoCommit is now off" ); ok( $dbh->commit, 'rollback() returns true' ); ok( $dbh->{AutoCommit} == 1, "AutoCommit is back on" ); $history = $dbh->{mock_all_history}; ok( @$history == 4, "Correct number of statements" ); is( $history->[0]->statement, 'BEGIN WORK' ); ok( @{$history->[0]->bound_params} == 0, 'No parameters' ); is( $history->[1]->statement, 'ROLLBACK' ); ok( @{$history->[1]->bound_params} == 0, 'No parameters' ); is( $history->[2]->statement, 'BEGIN WORK' ); ok( @{$history->[2]->bound_params} == 0, 'No parameters' ); is( $history->[3]->statement, 'COMMIT' ); ok( @{$history->[3]->bound_params} == 0, 'No parameters' ); done_testing(); DBD-Mock-1.55/t/009_info.t0000755000175000017500000000043113602403665011625 0ustar use 5.008; use strict; use warnings; use Test::More; BEGIN { use_ok('DBI'); } my $dbh = DBI->connect( 'dbi:Mock:', '', '' ); isa_ok($dbh, 'DBI::db'); $dbh->{mock_get_info} = { foo => 4 }; is( $dbh->get_info( 'foo' ), '4', "Retrieved info successfully" ); done_testing(); DBD-Mock-1.55/Changes0000644000175000017500000003607413602403665011156 0ustar Revision history for Perl extension DBD::Mock. 1.55 2019-12-30T14:20:00Z - Fixed bug rt131264 t/033_table_info.t fails (with older DBI) 1.54 2019-12-23T12:44:22Z - Added Bernhard Graf's 'Feature: one shot failure' merge request. - Fixed description of the failure attribute of mock_add_resultset. It no longer claims to support a hash ref (as it doesn't). Thanks to Bernhard Graf for both the bug report and a merge request that fixes it. - Fixed bug where it wasn't possible to replace a regular expression mock resultset. Thanks to Bernhard Graf for both the bug report and a merge request that fixes it. - Fixed bug where the failure attribute wasn't working with regular expression mock resultsets. Thanks to Bernhard Graf for both the bug report and a merge request that fixes it. 1.53 2019-12-03T10:50:57Z - Error handling in mock_add_resultset is no longer experimental - Attribute Aliasing is no longer experimental 1.52 2019-10-28T11:35:41Z - Added in callback feature for result sets so that their contents can be more dynamic. 1.51 2019-10-23T11:43:51Z - Fixed issue with using attribute aliases alongside a driver DSN in the DBI->connect call 1.50 2019-10-22T19:37:26Z - Added attribute aliases support for MariaDB 1.49 2019-09-12T12:59:51Z - Fixing tests that fail on some old versions of Perl 1.48 2019-09-12T06:34:47Z - Added execution_history feature to enable tracking of multiple executes for prepared statements. - Added support for $dbh->table_info calls - Fixed bug rt91055 "insert IGNORE" doesn't raise last_insert_id - Fixed bug rt82243 Bug with Regex in DBD::Mock::Session 1.47 2019-09-06T10:03:39Z - Applied Max Carey's patch from rt86294 adding support for nested keys to fetchall_hashref - Added experimental Connection Callbacks feature - Fixed build for Perl v5.8 1.46 2019-09-04T12:02:08Z - Added git-repo url to meta-data - Fixed bug rt70587 Spelling Mistake - Added regex support to mock_add_resultset 1.45 October 22, 2012 - Extended DBD::Mock::Session functionality - Added bind_param_array() to mocked statements - Added execute_array() to mocked statements 1.43 August 29, 2011 - 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 August 7, 2011 - Fixed bug rt66815 DBD::Mock::Session error clobbered - Fixed bug rt69460 Info on META.yml is outdated - Fixed bug rt69055 Spelling mistakes in POD - RaiseError now works 1.41 June 22, 2011 - Changed incorrect verion number 1.40 June 19, 2011 - Fixed bug rt44591 second preapre giving an error - Fixed bug rt57981 warnings during clone - Fixed bug rt63191 Synopsis errors - Fixed bug rt66813 Google's group link in the POD 1.39 November 9, 2008 - If a statement handle had bound columns, then the fetch() and fetchrow_arrayref() methods never returned false. After they exhausted their data, they kept returning empty array references. - Hid all packaged but DBD::Mock from PAUSE. 1.38 November 8, 2008 - Bumped minimum Perl to 5.8.1, since that's what DBI requires. - Fixed incorrect use of no_plan in t/025_mock_last_insert_id.t. - The handling of attributes passed to the constructor was not correct. The major symptom was that attributes (such as RaiseError) which were passed to the constructor could not be overridden in the database handle which was returned from connect(). As a result, some attributes set to a false value may return '' instead of 0. 1.37 June 12, 2008 - New co-maintainer (aka sucker), Dave Rolsky - Added support for $sth->bind_col() and $sth->bind_cols() - Fixed and clarified docs for the mock_last_insert_id and mock_start_insert_id attributes. The previous docs were both wrong and confusing - Applied patch from RT #35145 to add support for the Column attribute with selectcol_arrayref - patch by Matt Lawrence 1.36 October 18, 2007 - $dbh->last_insert_id() now works as documented - Added a "use 5.006;" in order to put a safeguard on the "use warnings;" statement a little further down. 1.35 July 9, 2007 - Applying path from RT #16951 to return new result set for repeated calls to $sth->execute(). Thanks to Marc Beyer for this. - added tests for this - Fixing RT #25892 to make mock_records method work correctly. - added test for this - applying patch from RT #26604 to fix AutoCommit behavior. Thanks to Ryan Gerry for this. 1.34 July, 29 2006 - Fixed how AutoCommit is handled to avoid $dbh caching (RobK) - Thanks to Chas Owens for patch and test for the mock_can_prepare, mock_can_execute, and mock_can_fetch features. 1.32 Wed Dec 14, 2005 - Fixed RT Bug #15599 - Fixed RT Bug #15602 - converted to Module::Build - removed the VERSION file, and adjusted the numbers in all places needed - added patch from Andrew W. Gibbs to allow the ARRAY version of 'mock_last_insert_id' attribute - added test file as well - added docs on it too - $sth->execute now returns the number of rows as per the DBI docs - added some tests for this >> DBD::Mock::Session - now allows regexp's in the bound_params list so that you can check your params are 'like' something, and not exactly something - Improved error messages 0.28 Wen July 13, 2005 - update to patch from Andrew McHarg to fix behavior in selectcol_arrayref() methods and tests - fix version in META.yml - some refactoring of fetchall_hashref(), fetchrow_hashref() to incorporate DBD-Mock error handling. 0.27 Mon July 11, 2005 - added NULL_RESULTSET constant - now allowing errors to be set with mock_add_resultset. Support is currently experimental, see the file 't/023_statement_failure.t' and the EXPERIMENTAL section of the docs for more information. - added patch from Collin Winter to fix a bug in the begin_work(), commit() and rollback() methods - added patch from Andrew McHarg for the fetchall_hashref(), fetchrow_hashref() and selectcol_arrayref() methods and tests 0.26 Fri Apr 08 2005 - added Rob Kinyon to the AUTHORS list - added get_info() and set_info() - added tests for this - added bind_param_inout() for DBD::Mock::st code from Thilo Planz (Thanks Thilo) - added tests for this - added mock_data_sources and mock_add_data_sources properties for the Driver and Database handles - added tests and docs for this - added begin_work(), commit() and rollback() method implementations which wrap the prepare() method and deal with the AutoCommit value per the DBI spec. - added tests and docs for this 0.25 Sat Feb 26 2005 - removed the DBD::Mock::_error_handler routine since it was actually redundant with the DBI::set_err method. This was actually the source of the RT Bug #11515 which was found by Shlomi Fish (thanks Shlomi) - adjusted some tests for this fix 0.24 Fri Jan 28 2005 - added the reset() method to the DBD::Mock::Session object so that a session can be used more than once. - added tests for this - added docs for this - fixed a bug where the HASH version of 'mock_add_resultset' would consume the result sets and they would not be reusable. We now copy the result sets so that every time the statement is called the same results are returned - did not need to add docs for this, they already documented this as the behavior (hence calling this a bug) - added tests for this 0.23 Tues Jan 25 2005 - removed the trace log tests from t/10_db_handle.t since they seemed to be a source of issues on Win32. My rationale is that it is a DBI thing, and therefore does not need to be tested by DBD::Mock. - added a few more tests to t/11_dr_handle.t to test the 'mock_connect_fail' feature - added some clarification in the docs about the 'mock_connect_fail' feature as well. 0.22 Mon Jan 24 2005 - added the 'mock_connect_fail' boolean attribute for the DBD::Mock driver handle, this will prevent DBI from connecting. It can be used to simulate a bad DSN or something like that. - added tests and documentation for this. - Thanks to Justin DeVuyst for this idea. 0.21 Sun Jan 16 2005 > DBD::Mock::Session - added the optional 'bound_params' slot for the DBD::Mock::Session object - added tests for this - added documentation for this - added error to handle cases where there are not enough states in a DBD::Mock::Session object. - added tests for this - added documentation for this - added the ability to remove a session (by setting it to a false value) - added tests for this - added documenation for this > DBD::Mock - added test to check about overwriting hash-based result sets with 'mock_add_resultset' attribute - added documentation for this 0.20 Fri Jan 14 2005 - Modified a set of tests in t/10_db_handle.t to pass on Cygwin. Thanks to Rob Kinyon for this code. This code now uses File::Temp to make the temp log file in a cross platform manner. If File::Temp is not found on the system, then the tests are skipped. 0.19 Fri Jan 7 2005 - changed the VERSION in lib/DBD/Mock.pm to be 1.23, allow me to explain... Chris Winters (the original author ) used the CVS derived VERSION, which when I took over the module (8 versions ago) was at 1.15. Since I was not using Chris's CVS repo to store this I decided to give Mock.pm the VERSION number found in the VERSION file. Well,... PAUSE's indexer doesn't like it since it is a lower number and would complain every time I uploaded a new version. I ignored these complaints (at my own peril) until now. I found out recently that if you had version 0.11 or below installed (where the Mock.pm was version 1.15 or below), then installing through the CPAN shell would tell you DBD::Mock was up to date, even though it wasn't. So in order to fix this issue, and make sure that all those who want to install and update DBD::Mock easily, I changed the version number of DBD::Mock to be 1.23 to reflect the number of updates I have done since Chris handed it over to me. *sigh* Okay good, thats off my chest now. 0.18 Wed Jan 5 2005 - added reset() method to the DBD::Mock::StatementTrack::Iterator object - added test and docs for this - added the DBD::Mock::Session object and added the support for it in the DBD::Mock driver - added tests and docs for this - Thanks to Rob Kinyon and Chris Winters for their feedback on this feature - some general POD cleanup and formatting 0.17 Thurs Nov 4 2004 - added the following items: - a 'mock_num_rows' attribute which will give you the number of records affected/returned by the last statement - a num_rows method in the DBD::Mock::StatementTrack object, which is where the above attribute gets it's value - added the 'rows' method for statement handles (which didnt work before) 0.16 Sat Oct 30 2004 - minor change to the DBD::Mock::StatementTrack::Iterator behavior. It no longer derefs the history array, so it maintains a reference to it and therefore can be used like this: get-statement-iterator run-query check-next-statement-in-iterator run-query check-next-statement-in-iterator ... This prevents the need to re-fetch the iterator after each query. 0.15 Fri Oct 29 2004 - added the DBD::Mock::StatementTrack::Iterator object which can be accessed from the 'mock_all_history_iterator' attribute. - write the docs and test for it 0.14 Fri Oct 29 2004 - added the mock_last_insert_id attribute which will get incremented upon each INSERT query run. - added tests and docs for this - added the mock_start_insert_id attirbute so that you can both reset and set the start number for mock_last_insert_id - added tests and docs for this ** EXPERIMENTAL FEATURE (use caution) ** - added a feature to alias attributes. Basically it allows you to alias an expected attribute like 'mysql_insertid' to something DBD::Mock already has like 'mock_last_insert_id'. Right now this feature is highly experimental, and has been added as a first attempt automatically handle some of the DBD specific attributes which are commonly used/accessed in DBI programming. 0.13 Thurs Oct 28 2004 - added prepare_cached as suggested by Rob Kinyon in RT bug #7331. Also added his test script in 15_prepare_cached.t 0.12 Thurs Sept 2 2004 ** First version maintained by Stevan Little ** - built up the test suite to 89.7% coverage - removed the undocumented 'mock_auto_commit' since it really was not very useful at this point. - added the DBD::Mock::Pool functionality - added tests for this - added documentation for this - added pod.t to test suite - removed AUTOLOAD in DBD::Mock::StatementTrack and replaced it with hand coded methods (sorry I really dislike AUTOLOAD) - centralized error handling in DBD::Mock::_error_handler 0.11 Fri Jul 23 10:35:13 EDT 2004 - Fix CPAN Bug #7057: add a no-op 'disconnect_all()' to DBD::Mock::dr to support DBI versions earlier than 1.34. - Add the ability to create SQL parsers that get fired on a prepare(). This way you can ensure your application generates correct SQL and have the system fail at the right time. Thanks to Rob Kinyon for the idea. 0.10 Sat May 8 14:12:39 EDT 2004 - Incorporate number of patches from Stevan Little to implement 'mock_can_connect', which allows you to simulate a downed database. Add supporting tests for database and statement usage. - Add the ability for 'mock_add_resultset' to associate a resultset with a particular SQL statement. Thanks to Stevan for the idea. - Add documentation for database handle property 'mock_add_resultset' 0.02 Tue Mar 9 12:56:54 EST 2004 Add 'VERSION' to MANIFEST, thanks to Mike Castle for the note. 0.01 Sun Mar 7 23:24:24 EST 2004 Initial version spawned from DBD::NullP shipped with the DBI. Many thanks much to Tim Bunce for the pointer and the original code. DBD-Mock-1.55/CONTRIBUTING.md0000644000175000017500000000072313602403665012104 0ustar # Contributing to the DBD::Mock module If you'd like to contribute to the DBD::Mock module then I suggest you use one of the following ways: * Post a ticket to the [RT](https://rt.cpan.org/Public/Dist/Display.html?Name=DBD-Mock) queue for the module. * Raise an issue in the [GitLab project](https://gitlab.com/scrapheap/DBD-Mock/issues) * If you have actual code to commit then make a Merge Request to the [GitLab project](https://gitlab.com/scrapheap/DBD-Mock) DBD-Mock-1.55/Build.PL0000644000175000017500000000045513602403665011151 0ustar # ========================================================================= # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. # DO NOT EDIT DIRECTLY. # ========================================================================= use 5.008_001; use strict; use Module::Build::Tiny 0.035; Build_PL(); DBD-Mock-1.55/LICENSE0000644000175000017500000004375413602403665010673 0ustar This software is copyright (c) 2019 by Chris Winters . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2019 by Chris Winters . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2019 by Chris Winters . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DBD-Mock-1.55/cpanfile0000644000175000017500000000026113602403665011354 0ustar requires 'DBI', '1.3'; requires 'perl', 'v5.8.1'; requires 'List::Util', '1.27'; on build => sub { requires 'Test::Exception', '0.31'; requires 'Test::More', '0.47'; }; DBD-Mock-1.55/META.json0000664000175000017500000000565113602403665011303 0ustar { "abstract" : "Mock database driver for testing", "author" : [ "Chris Winters ", "Stevan Little ", "Rob Kinyon ", "Mariano Wahlmann ", "Jason Cooper " ], "dynamic_config" : 0, "generated_by" : "Minilla/v3.1.6", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBD-Mock", "no_index" : { "directory" : [ "t", "xt", "inc", "share", "eg", "examples", "author", "builder" ] }, "prereqs" : { "build" : { "requires" : { "Test::Exception" : "0.31", "Test::More" : "0.47" } }, "configure" : { "requires" : { "Module::Build::Tiny" : "0.035" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::MinimumVersion::Fast" : "0.04", "Test::PAUSE::Permissions" : "0.07", "Test::Pod" : "1.41", "Test::Spellunker" : "v0.2.7" } }, "runtime" : { "requires" : { "DBI" : "1.3", "List::Util" : "1.27", "perl" : "5.008001" } } }, "provides" : { "DBD::Mock" : { "file" : "lib/DBD/Mock.pm", "version" : "1.55" }, "DBD::Mock::Pool" : { "file" : "lib/DBD/Mock/Pool.pm" }, "DBD::Mock::Pool::db" : { "file" : "lib/DBD/Mock/Pool/db.pm" }, "DBD::Mock::Session" : { "file" : "lib/DBD/Mock/Session.pm" }, "DBD::Mock::StatementTrack" : { "file" : "lib/DBD/Mock/StatementTrack.pm" }, "DBD::Mock::StatementTrack::Iterator" : { "file" : "lib/DBD/Mock/StatementTrack/Iterator.pm" }, "DBD::Mock::db" : { "file" : "lib/DBD/Mock/db.pm" }, "DBD::Mock::dr" : { "file" : "lib/DBD/Mock/dr.pm" }, "DBD::Mock::st" : { "file" : "lib/DBD/Mock/st.pm" } }, "release_status" : "stable", "resources" : { "homepage" : "https://gitlab.com/scrapheap/DBD-Mock", "repository" : { "url" : "git://gitlab.com/scrapheap/DBD-Mock.git", "web" : "https://gitlab.com/scrapheap/DBD-Mock" } }, "version" : "1.55", "x_authority" : "cpan:JLCOOPER", "x_contributors" : [ "Bernhard Graf ", "Chisel ", "Dave Rolsky ", "Frédéric Brière ", "Gines R ", "Max Carey ", "gregor herrmann ", "wu-lee " ], "x_serialization_backend" : "JSON::PP version 2.27300_01", "x_static_install" : 1 } DBD-Mock-1.55/MANIFEST0000664000175000017500000000234313602403665011006 0ustar Build.PL CONTRIBUTING.md Changes LICENSE META.json README.md cpanfile lib/DBD/Mock.pm lib/DBD/Mock/Pool.pm lib/DBD/Mock/Pool/db.pm lib/DBD/Mock/Session.pm lib/DBD/Mock/StatementTrack.pm lib/DBD/Mock/StatementTrack/Iterator.pm lib/DBD/Mock/db.pm lib/DBD/Mock/dr.pm lib/DBD/Mock/st.pm minil.toml 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/030_st_execute_array.t t/031_setup_callbacks.t t/032_selectall_arrayref.t t/033_table_info.t t/998_pod.t t/999_pod_coverage.t t/bug_015602.t t/bug_066815.t t/bug_071438.t t/bug_082243.t t/bug_117162.t META.yml MANIFESTDBD-Mock-1.55/README.md0000664000175000017500000013355413602403665011145 0ustar # NAME DBD::Mock - Mock database driver for testing # SYNOPSIS use DBI; # connect to your as normal, using 'Mock' as your driver name my $dbh = DBI->connect( 'DBI:Mock:', '', '' ) || die "Cannot create handle: $DBI::errstr\n"; # create a statement handle as normal and execute with parameters my $sth = $dbh->prepare( 'SELECT this, that FROM foo WHERE id = ?' ); $sth->execute( 15 ); # Now query the statement handle as to what has been done with it my $mock_params = $sth->{mock_params}; print "Used statement: ", $sth->{mock_statement}, "\n", "Bound parameters: ", join( ', ', @{ $mock_params } ), "\n"; # DESCRIPTION Testing with databases can be tricky. If you are developing a system married to a single database then you can make some assumptions about your environment and ask the user to provide relevant connection information. But if you need to test a framework that uses DBI, particularly a framework that uses different types of persistence schemes, then it may be more useful to simply verify what the framework is trying to do -- ensure the right SQL is generated and that the correct parameters are bound. `DBD::Mock` makes it easy to just modify your configuration (presumably held outside your code) and just use it instead of `DBD::Foo` (like [DBD::Pg](https://metacpan.org/pod/DBD::Pg) or [DBD::mysql](https://metacpan.org/pod/DBD::mysql)) in your framework. There is no distinct area where using this module makes sense. (Some people may successfully argue that this is a solution looking for a problem...) Indeed, if you can assume your users have something like [DBD::AnyData](https://metacpan.org/pod/DBD::AnyData) or [DBD::SQLite](https://metacpan.org/pod/DBD::SQLite) or if you do not mind creating a dependency on them then it makes far more sense to use these legitimate driver implementations and test your application in the real world -- at least as much of the real world as you can create in your tests... And if your database handle exists as a package variable or something else easily replaced at test-time then it may make more sense to use [Test::MockObject](https://metacpan.org/pod/Test::MockObject) to create a fully dynamic handle. There is an excellent article by chromatic about using [Test::MockObject](https://metacpan.org/pod/Test::MockObject) in this and other ways, strongly recommended. (See ["SEE ALSO"](#see-also) for a link) ## How does it work? `DBD::Mock` comprises a set of classes used by DBI to implement a database driver. But instead of connecting to a datasource and manipulating data found there it tracks all the calls made to the database handle and any created statement handles. You can then inspect them to ensure what you wanted to happen actually happened. For instance, say you have a configuration file with your database connection information: [DBI] dsn = DBI:Pg:dbname=myapp user = foo password = bar And this file is read in at process startup and the handle stored for other procedures to use: package ObjectDirectory; my ( $DBH ); sub run_at_startup { my ( $class, $config ) = @_; $config ||= read_configuration( ... ); my $dsn = $config->{DBI}{dsn}; my $user = $config->{DBI}{user}; my $pass = $config->{DBI}{password}; $DBH = DBI->connect( $dsn, $user, $pass ) || die ...; } sub get_database_handle { return $DBH; } A procedure might use it like this (ignoring any error handling for the moment): package My::UserActions; sub fetch_user { my ( $class, $login ) = @_; my $dbh = ObjectDirectory->get_database_handle; my $sql = q{ SELECT login_name, first_name, last_name, creation_date, num_logins FROM users WHERE login_name = ? }; my $sth = $dbh->prepare( $sql ); $sth->execute( $login ); my $row = $sth->fetchrow_arrayref; return ( $row ) ? User->new( $row ) : undef; } So for the purposes of our tests we just want to ensure that: - 1. The right SQL is being executed - 2. The right parameters are bound Assume whether the SQL actually **works** or not is irrelevant for this test :-) To do that our test might look like: my $config = ObjectDirectory->read_configuration( ... ); $config->{DBI}{dsn} = 'DBI:Mock:'; ObjectDirectory->run_at_startup( $config ); my $login_name = 'foobar'; my $user = My::UserActions->fetch_user( $login_name ); # Get the handle from ObjectDirectory; # this is the same handle used in the # 'fetch_user()' procedure above my $dbh = ObjectDirectory->get_database_handle(); # Ask the database handle for the history # of all statements executed against it my $history = $dbh->{mock_all_history}; # Now query that history record to # see if our expectations match reality is(scalar(@{$history}), 1, 'Correct number of statements executed' ; my $login_st = $history->[0]; like($login_st->statement, qr/SELECT login_name.*FROM users WHERE login_name = ?/sm, 'Correct statement generated' ); my $params = $login_st->bound_params; is(scalar(@{$params}), 1, 'Correct number of parameters bound'); is($params->[0], $login_name, 'Correct value for parameter 1' ); # Reset the handle for future operations $dbh->{mock_clear_history} = 1; The list of properties and what they return is listed below. But in an overall view: - A database handle contains the history of all statements created against it. Other properties set for the handle (e.g., `PrintError`, `RaiseError`) are left alone and can be queried as normal, but they do not affect anything. (A future feature may track the sequence/history of these assignments but if there is no demand it probably will not get implemented.) - A statement handle contains the statement it was prepared with plus all bound parameters or parameters passed via `execute()`. It can also contain predefined results for the statement handle to `fetch`, track how many fetches were called and what its current record is. ## A Word of Warning This may be an incredibly naive implementation of a DBD. But it works for me... # DBD::Mock Since this is a normal DBI statement handle we need to expose our tracking information as properties (accessed like a hash) rather than methods. ## Database Driver Properties - **`mock_connect_fail`** This is a boolean property which when set to true (`1`) will not allow DBI to connect. This can be used to simulate a DSN error or authentication failure. This can then be set back to false (`0`) to resume normal DBI operations. Here is an example of how this works: # install the DBD::Mock driver my $drh = DBI->install_driver('Mock'); $drh->{mock_connect_fail} = 1; # this connection will fail my $dbh = DBI->connect('dbi:Mock:', '', '') || die "Cannot connect"; # this connection will throw an exception my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1 }); $drh->{mock_connect_fail} = 0; # this will work now ... my $dbh = DBI->connect(...); This feature is conceptually different from the `mock_can_connect` attribute of the `$dbh` in that it has a driver-wide scope, where `mock_can_connect` is handle-wide scope. It also only prevents the initial connection, any `$dbh` handles created prior to setting `mock_connect_fail` to true (`1`) will still go on working just fine. - **`mock_data_sources`** This is an ARRAY reference which holds fake data sources which are returned by the Driver and Database Handle's `data_source()` method. - **`mock_add_data_sources`** This takes a string and adds it to the `mock_data_sources` attribute. ## Database Handle Properties - **`mock_all_history`** Returns an array reference with all history (a.k.a. `DBD::Mock::StatementTrack`) objects created against the database handle in the order they were created. Each history object can then report information about the SQL statement used to create it, the bound parameters, etc.. - **`mock_all_history_iterator`** Returns a `DBD::Mock::StatementTrack::Iterator` object which will iterate through the current set of `DBD::Mock::StatementTrack` object in the history. See the ["DBD::Mock::StatementTrack::Iterator"](#dbd-mock-statementtrack-iterator) documentation below for more information. - **`mock_clear_history`** If set to a true value all previous statement history operations will be erased. This **includes** the history of currently open handles, so if you do something like: my $dbh = get_handle( ... ); my $sth = $dbh->prepare( ... ); $dbh->{mock_clear_history} = 1; $sth->execute( 'Foo' ); You will have no way to learn from the database handle that the statement parameter 'Foo' was bound. This is useful mainly to ensure you can isolate the statement histories from each other. A typical sequence will look like: set handle to framework perform operations analyze mock database handle reset mock database handle history perform more operations analyze mock database handle reset mock database handle history ... - **`mock_can_connect`** This statement allows you to simulate a downed database connection. This is useful in testing how your application/tests will perform in the face of some kind of catastrophic event such as a network outage or database server failure. It is a simple boolean value which defaults to on, and can be set like this: # turn the database off $dbh->{mock_can_connect} = 0; # turn it back on again $dbh->{mock_can_connect} = 1; The statement handle checks this value as well, so something like this will fail in the expected way: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{mock_can_connect} = 0; # blows up! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); if ( $@ ) { # Here, $DBI::errstr = 'No connection present' } Turning off the database after a statement prepare will fail on the statement `execute()`, which is hopefully what you would expect: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); # ok! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); $dbh->{mock_can_connect} = 0; # blows up! $sth->execute; Similarly: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); # ok! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); # ok! $sth->execute; $dbh->{mock_can_connect} = 0; # blows up! my $row = $sth->fetchrow_arrayref; Note: The handle attribute `Active` and the handle method `ping` will behave according to the value of `mock_can_connect`. So if `mock_can_connect` were to be set to `0` (or off), then both `Active` and `ping` would return false values (or `0`). - **`mock_add_resultset( \@resultset | \%resultset_and_options )`** This stocks the database handle with a record set, allowing you to seed data for your application to see if it works properly. Each recordset is a simple arrayref of arrays with the first arrayref being the field names used. Every time a statement handle is created it asks the database handle if it has any resultsets available and if so uses it. Here is a sample usage, partially from the test suite: my @user_results = ( [ 'login', 'first_name', 'last_name' ], [ 'cwinters', 'Chris', 'Winters' ], [ 'bflay', 'Bobby', 'Flay' ], [ 'alincoln', 'Abe', 'Lincoln' ], ); my @generic_results = ( [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ); my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{mock_add_resultset} = \@user_results; # add first resultset $dbh->{mock_add_resultset} = \@generic_results; # add second resultset my ( $sth ); eval { $sth = $dbh->prepare( 'SELECT login, first_name, last_name FROM foo' ); $sth->execute(); }; # this will fetch rows from the first resultset... my $row1 = $sth->fetchrow_arrayref; my $user1 = User->new( login => $row->[0], first => $row->[1], last => $row->[2] ); is( $user1->full_name, 'Chris Winters' ); my $row2 = $sth->fetchrow_arrayref; my $user2 = User->new( login => $row->[0], first => $row->[1], last => $row->[2] ); is( $user2->full_name, 'Bobby Flay' ); ... my $sth_generic = $dbh->prepare( 'SELECT foo, bar FROM baz' ); $sth_generic->execute; # this will fetch rows from the second resultset... my $row = $sth->fetchrow_arrayref; It is possible to assign a hashref where the resultset must be given as value for the `results` key: $dbh->{mock_add_resultset} = { results => [ [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ], }; The reason for the hashref form is that you can add options as described in the following. You can associate a resultset with a particular SQL statement instead of adding them in the order they will be fetched: $dbh->{mock_add_resultset} = { sql => 'SELECT foo, bar FROM baz', results => [ [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ], }; This will return the given results when the statement '`SELECT foo, bar FROM baz`' is prepared/executed. Note that they will be returned **every time** the statement is prepared/executed, not just the first. It should also be noted that if you want, for some reason, to change the result set bound to a particular SQL statement, all you need to do is add the result set again with the same SQL statement and `DBD::Mock` will overwrite it. If the `sql` parameter is a regular expression reference then the results will be returned for any SQL statements that matches it: $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo FROM/i, results => [ [ 'foo' ], [ 'this_one' ], ], }; If an SQL statement matches both a specified SQL statement result set and a regular expression result set then the specified SQL statement takes precedence. If two regular expression result sets match then the first one added takes precedence: # Set up our first regex matching result set $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo/, results => [ [ 'foo' ], [ 200 ] ], }; # Set up our second regex matching result set # Note - This results set would never be used as the one above will match # and thus take precedence $dbh->{mock_add_resultset} = { sql => qr/^SELECT foo FROM/, results => [ [ 'foo' ], [ 300 ] ], }; # Set up our first statically defined result set # This result set will take precedence over the regex matching ones above $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 50 ]] }; # This query will be served by the first regex matching result set my $sth = $dbh->prepare('SELECT foo FROM oof'); $sth->execute() my ($result) = $sth->fetchrow_array(); is( $result, 200 ); # This quere will be served by the statically defined result set $sth = $dbh->prepare('SELECT foo FROM bar'); $sth->execute(); my ($result2) = $sth->fetchrow_array(); is( $result2, 50 ); It should also be noted that the `rows` method will return the number of records stocked in the result set. So if your code/application makes use of the `$sth->rows` method for things like `UPDATE` and `DELETE` calls you should stock the result set like so: $dbh->{mock_add_resultset} = { sql => 'UPDATE foo SET baz = 1, bar = 2', # this will appear to have updated 3 rows results => [[ 'rows' ], [], [], []], }; # or ... $dbh->{mock_add_resultset} = { sql => 'DELETE FROM foo WHERE bar = 2', # this will appear to have deleted 1 row results => [[ 'rows' ], []], }; Now I admit this is not the most elegant way to go about this, but it works for me for now, and until I can come up with a better method, or someone sends me a patch ;) it will do for now. If you want a given statement to fail, you will have to use the hashref method and add a `failure` key. That key must be handed an arrayref with the error number and error string, in that order. $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => DBD::Mock->NULL_RESULTSET, failure => [ 5, 'Ooops!' ], }; Without the `sql` attribute the next statement will fail in any case: $dbh->{mock_add_resultset} = { results => DBD::Mock->NULL_RESULTSET, failure => [ 5, 'Ooops!' ], }; - **`mock_get_info`** This attribute can be used to set up values for `get_info()`. It takes a hashref of attribute\_name/value pairs. See [DBI](https://metacpan.org/pod/DBI) for more information on the information types and their meaning. - **`mock_session`** This attribute can be used to set a current `DBD::Mock::Session` object. For more information on this, see the ["DBD::Mock::Session"](#dbd-mock-session) docs below. This attribute can also be used to remove the current session from the `$dbh` simply by setting it to `undef`. - **`mock_last_insert_id`** This attribute is incremented each time an `INSERT` statement is passed to `prepare` on a per-handle basis. It's starting value can be set with the `mock_start_insert_id` attribute (see below). $dbh->{mock_start_insert_id} = 10; my $sth = $dbh->prepare('INSERT INTO Foo (foo, bar) VALUES(?, ?)'); $sth->execute(1, 2); # $dbh->{mock_last_insert_id} == 10 $sth->execute(3, 4); # $dbh->{mock_last_insert_id} == 11 For more examples, please refer to the test file `t/025_mock_last_insert_id.t`. To access `last_insert_id` using driver specific attributes like `mysql_insertid` and `mariadb_insertid` then you can use ["Attribute Aliasing"](#attribute-aliasing). - **`mock_start_insert_id`** This attribute can be used to set a start value for the `mock_last_insert_id` attribute. It can also be used to effectively reset the `mock_last_insert_id` attribute as well. This attribute also can be used with an ARRAY ref parameter, it's behavior is slightly different in that instead of incrementing the value for every `prepare` it will only increment for each `execute`. This allows it to be used over multiple `execute` calls in a single `$sth`. It's usage looks like this: $dbh->{mock_start_insert_id} = [ 'Foo', 10 ]; $dbh->{mock_start_insert_id} = [ 'Baz', 20 ]; my $sth1 = $dbh->prepare('INSERT INTO Foo (foo, bar) VALUES(?, ?)'); my $sth2 = $dbh->prepare('INSERT INTO Baz (baz, buz) VALUES(?, ?)'); $sth1->execute(1, 2); # $dbh->{mock_last_insert_id} == 10 $sth2->execute(3, 4); # $dbh->{mock_last_insert_id} == 20 Note that `DBD::Mock`'s matching of table names in `INSERT` statements is fairly simple, so if your table names are quoted in the insert statement (`INSERT INTO "Foo"`) then you need to quote the name for `mock_start_insert_id`: $dbh->{mock_start_insert_id} = [ q{"Foo"}, 10 ]; - **`mock_add_parser`** DBI provides some simple parsing capabilities for `SELECT` statements to ensure that placeholders are bound properly. And typically you may simply want to check after the fact that a statement is syntactically correct, or at least what you expect. But other times you may want to parse the statement as it is prepared rather than after the fact. There is a hook in this mock database driver for you to provide your own parsing routine or object. The syntax is simple: $dbh->{mock_add_parser} = sub { my ( $sql ) = @_; unless ( $sql =~ /some regex/ ) { die "does not contain secret fieldname"; } }; You can also add more than one for a handle. They will be called in order, and the first one to fail will halt the parsing process: $dbh->{mock_add_parser} = \&parse_update_sql; $dbh->{mock_add-parser} = \&parse_insert_sql; Depending on the `PrintError` and `RaiseError` settings in the database handle any parsing errors encountered will issue a `warn` or `die`. No matter what the statement handle will be `undef`. Instead of providing a subroutine reference you can use an object. The only requirement is that it implements the method `parse()` and takes a SQL statement as the only argument. So you should be able to do something like the following (untested): my $parser = SQL::Parser->new( 'mysql', { RaiseError => 1 } ); $dbh->{mock_add_parser} = $parser; - **`mock_data_sources`** & **`mock_add_data_sources`** These properties will dispatch to the Driver's properties of the same name. ## Attribute Aliasing Basically this feature allows you to alias attributes to other attributes. So for instance, you can alias a commonly expected attribute like `mysql_insertid` to something `DBD::Mock` already has like `mock_last_insert_id`. While you can also just set `mysql_insertid` yourself, this functionality allows it to take advantage of things like the autoincrementing of the `mock_last_insert_id` attribute. The functionality is off by default so as to not cause any issues with backwards compatibility, but can easily be turned on and off like this: # turn it on $DBD::Mock::AttributeAliasing++; # turn it off $DBD::Mock::AttributeAliasing = 0; Once this is turned on, you will need to choose a database specific attribute aliasing table like so: DBI->connect('dbi:Mock:MySQL', '', ''); Or, by using the database name if using driver DSNs: DBI->connect('dbi:Mock:host=localhost;port=3306;database=MySQL', '', ''); The `MySQL` in the DSN will be picked up and the MySQL specific attribute aliasing will be used. Right now there is only minimal support for MySQL and MariaDB: - MySQL Currently the `mysql_insertid` attribute for `$dbh` and `$sth` are aliased to the `$dbh` attribute `mock_last_insert_id`. - MariaDB Currently the `mariadb_insertid` attribute for `$dbh` and `$sth` are aliased to the `$dbh` attribute `mock_last_insert_id`. It is possible to add more aliases though, using the `DBD::Mock:_set_mock_attribute_aliases` function (see the source code for details) ## Database Driver Methods - **`last_insert_id`** This returns the value of `mock_last_insert_id`. In order to capture `begin_work()`, `commit()`, and `rollback()`, `DBD::Mock` will create statements for them, as if you had issued them in the appropriate SQL command line program. They will go through the standard `prepare()`-`execute()` cycle, meaning that any custom SQL parsers will be triggered and `DBD::Mock::Session` will need to know about these statements. - **`begin_work`** This will create a statement with SQL of `BEGIN WORK` and no parameters. - **`commit`** This will create a statement with SQL of `COMMIT` and no parameters. - **`rollback`** This will create a statement with SQL of `ROLLBACK` and no parameters. ## Statement Handle Properties - **`Active`** Returns true if the handle is a `SELECT` and has more records to fetch, false otherwise. (From the DBI.) - **`mock_statement`** The SQL statement this statement handle was `prepare`d with. So if the handle was created with: my $sth = $dbh->prepare( 'SELECT * FROM foo' ); This would return: SELECT * FROM foo The original statement is unmodified so if you are checking against it in tests you may want to use a regex rather than a straight equality check. (However if you use a phrasebook to store your SQL externally you are a step ahead...) - **`mock_fields`** Fields used by the statement. As said elsewhere we do no analysis or parsing to find these, you need to define them beforehand. That said, you do not actually need this very often. Note that this returns the same thing as the normal statement property `FIELD`. - **`mock_params`** Returns an arrayref of parameters bound to this statement in the order specified by the bind type. For instance, if you created and stocked a handle with: my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); $sth->bind_param( 2, 'yes' ); $sth->bind_param( 1, 7783 ); This would return: [ 7738, 'yes' ] The same result will occur if you pass the parameters via `execute()` instead: my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); $sth->execute( 7783, 'yes' ); The same using named parameters my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = :id AND is_active = :active' ); $sth->bind_param( ':id' => 7783 ); $sth->bind_param( ':active' => 'yes' ); - **`mock_param_attrs`** Returns an arrayref of any attributes (parameter type) defined for bound parameters (note: you rarely need to define attributes for bound parameters). Where an attribute/type hasn't been that slot in the returned arrayref will be `undef`. e.g. for: my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); $sth->bind_param( 2, 'yes' ); $sth->bind_param( 1 7783, SQL_INTEGER ); This would return: [ SQL_INTEGER, undef ] Passing parameters via `execute()` will always populate the array with `undef`, so for: $sth->execute( 7783, 'yes' ); This would return: [ undef, undef ] - **`mock_execution_history`** Returns an arrayref where each entry contains the details for an execution of the prepared statement. e.g. after: my $sth = $dbh->prepare( 'SELECT * FROM foo WHERE id = ? AND is_active = ?' ); $sth->bind_param( 2, 'yes' ); $sth->bind_param( 1 7783, SQL_INTEGER ); $sth->execute(); $sth->execute( 1023, 'no' ); Then `$sth->{mock_execution_history}` would be: [ { params => [ 7783, 'yes' ], attrs => [ SQL_INTEGER, undef ], }, { params => [ 1023, 'no' ], attrs => [ undef, undef ], } ] - **`mock_records`** An arrayref of arrayrefs representing the records the mock statement was stocked with. - **`mock_num_records`** Number of records the mock statement was stocked with; if never stocked it is still `0`. (Some weirdos might expect undef...) - **`mock_num_rows`** This returns the same value as _mock\_num\_records_. And is what is returned by the `rows` method of the statement handle. - **`mock_current_record_num`** Current record the statement is on; returns `0` in the instances when you have not yet called `execute()` and if you have not yet called a `fetch` method after the execute. - **`mock_is_executed`** Whether `execute()` has been called against the statement handle. Returns 'yes' if so, 'no' if not. - **`mock_is_finished`** Whether `finish()` has been called against the statement handle. Returns 'yes' if so, 'no' if not. - **`mock_is_depleted`** Returns 'yes' if all the records in the recordset have been returned. If no `fetch()` was executed against the statement, or If no return data was set this will return 'no'. - **`mock_my_history`** Returns a `DBD::Mock::StatementTrack` object which tracks the actions performed by this statement handle. Most of the actions are separately available from the properties listed above, so you should never need this. # DBD::Mock::Pool This module can be used to emulate [Apache::DBI](https://metacpan.org/pod/Apache::DBI) style DBI connection pooling. Just as with `Apache::DBI`, you must enable `DBD::Mock::Pool` before loading DBI. use DBD::Mock qw(Pool); # followed by ... use DBI; While this may not seem to make a lot of sense in a single-process testing scenario, it can be useful when testing code which assumes a multi-process `Apache::DBI` pooled environment. # DBD::Mock::StatementTrack Under the hood this module does most of the work with a `DBD::Mock::StatementTrack` object. This is most useful when you are reviewing multiple statements at a time, otherwise you might want to use the `mock_*` statement handle attributes instead. - **`new( %params )`** Takes the following parameters: - **`return_data`**: Arrayref of return data records - **`fields`**: Arrayref of field names - **`bound_params`**: Arrayref of bound parameters - **`bound_param_attrs`**: Arrayref of bound parameter attributes - **`statement`** (Statement attribute `mock_statement`) Gets/sets the SQL statement used. - **`fields`** (Statement attribute `mock_fields`) Gets/sets the fields to use for this statement. - **`bound_params`** (Statement attribute `mock_params`) Gets/set the bound parameters to use for this statement. - **`return_data`** (Statement attribute `mock_records`) Gets/sets the data to return when asked (that is, when someone calls `fetch` on the statement handle). - **`current_record_num`** (Statement attribute `mock_current_record_num`) Gets/sets the current record number. - **`is_active()`** (Statement attribute `Active`) Returns true if the statement is a `SELECT` and has more records to fetch, false otherwise. (This is from the DBI, see the 'Active' docs under 'ATTRIBUTES COMMON TO ALL HANDLES'.) - **`is_executed( $yes_or_no )`** (Statement attribute `mock_is_executed`) Sets the state of the tracker `executed` flag. - **`is_finished( $yes_or_no )`** (Statement attribute `mock_is_finished`) If set to `yes` tells the tracker that the statement is finished. This resets the current record number to `0` and clears out the array ref of returned records. - **`is_depleted()`** (Statement attribute `mock_is_depleted`) Returns true if the current record number is greater than the number of records set to return. - **`num_fields`** Returns the number of fields set in the `fields` parameter. - **`num_rows`** Returns the number of records in the current result set. - **`num_params`** Returns the number of parameters set in the `bound_params` parameter. - **`bound_param( $param_num, $value )`** Sets bound parameter `$param_num` to `$value`. Returns the arrayref of currently-set bound parameters. This corresponds to the `bind_param` statement handle call. - **`bound_param_trailing( @params )`** Pushes `@params` onto the list of already-set bound parameters. - **`mark_executed()`** Tells the tracker that the statement has been executed and resets the current record number to `0`. - **`next_record()`** If the statement has been depleted (all records returned) returns `undef`; otherwise it gets the current record for returning, increments the current record number and returns the current record. - **`to_string()`** Tries to give a decent depiction of the object state for use in debugging. # DBD::Mock::StatementTrack::Iterator This object can be used to iterate through the current set of `DBD::Mock::StatementTrack` objects in the history by fetching the `mock_all_history_iterator` attribute from a database handle. This object is very simple and is meant to be a convenience to make writing long test script easier. Aside from the constructor (`new`) this object has the following methods. - **`next()`** Calling `next` will return the next `DBD::Mock::StatementTrack` object in the history. If there are no more `DBD::Mock::StatementTrack` objects available, then this method will return false. - **`reset()`** This will reset the internal pointer to the beginning of the statement history. # DBD::Mock::Session The `DBD::Mock::Session` object is an alternate means of specifying the SQL statements and result sets for `DBD::Mock`. The idea is that you can specify a complete 'session' of usage, which will be verified through `DBD::Mock`. Here is an example: my $session = DBD::Mock::Session->new('my_session' => ( { statement => "SELECT foo FROM bar", # as a string results => [[ 'foo' ], [ 'baz' ]] }, { statement => qr/UPDATE bar SET foo \= \'bar\'/, # as a reg-exp results => [[]] }, { statement => sub { # as a CODE ref my ($SQL, $state) = @_; return $SQL eq "SELECT foo FROM bar"; }, results => [[ 'foo' ], [ 'bar' ]] }, { # with bound parameters statement => "SELECT foo FROM bar WHERE baz = ? AND borg = ?", # check exact bound param value, # then check it against regexp bound_params => [ 10, qr/\d+/ ], results => [[ 'foo' ], [ 'baz' ]] } )); As you can see, a session is essentially made up a list of HASH references we call 'states'. Each state has a `statement` and a set of `results`. If `DBD::Mock` finds a session in the `mock_session` attribute, then it will pass the current `$dbh` and SQL statement to that `DBD::Mock::Session`. The SQL statement will be checked against the `statement` field in the current state. If it passes, then the `results` of the current state will get fed to `DBD::Mock` through the `mock_add_resultset` attribute. We then advance to the next state in the session, and wait for the next call through `DBD::Mock`. If at any time the SQL statement does not match the current state's `statement`, or the session runs out of available states, an error will be raised (and propagated through the normal DBI error handling based on your values for `RaiseError` and `PrintError`). As can be seen in the session element, bound parameters can also be supplied and tested. In this statement, the SQL is compared, then when the statement is executed, the bound parameters are also checked. The bound parameters must match in both number of parameters and the parameters themselves, or an error will be raised. As can also be seen in the example above, `statement` fields can come in many forms. The simplest is a string, which will be compared using `eq` against the currently running statement. The next is a reg-exp reference, this too will get compared against the currently running statement. The last option is a CODE ref, this is sort of a catch-all to allow for a wide range of SQL comparison approaches (including using modules like [SQL::Statement](https://metacpan.org/pod/SQL::Statement) or [SQL::Parser](https://metacpan.org/pod/SQL::Parser) for detailed functional comparisons). The first argument to the CODE ref will be the currently active SQL statement to compare against, the second argument is a reference to the current state HASH (in case you need to alter the results, or store extra information). The CODE is evaluated in boolean context and throws and exception if it is false. - **`new ($session_name, @session_states)`** A `$session_name` can be optionally be specified, along with at least one `@session_states`. If you don't specify a `$session_name`, then a default one will be created for you. The `@session_states` must all be HASH references as well, if this conditions fail, an exception will be thrown. - **`verify_statement ($dbh, $SQL)`** This will check the `$SQL` against the current state's `statement` value, and if it passes will add the current state's `results` to the `$dbh`. If for some reason the `statement` value is bad, not of the prescribed type, an exception is thrown. See above for more details. - **`verify_bound_params ($dbh, $params)`** If the `bound_params` slot is available in the current state, this will check the `$params` against the current state's `bound_params` value. Both number of parameters and the parameters themselves must match, or an error will be raised. - **`reset`** Calling this method will reset the state of the session object so that it can be reused. # EXPERIMENTAL FUNCTIONALITY All functionality listed here is highly experimental and should be used with great caution (if at all). - Connection Callbacks This feature allows you to define callbacks that get executed when `DBI->connect` is called. To set a series of callbacks you use the `DBD::Mock::dr::set_connect_callbacks` function use DBD::Mock::dr; DBD::Mock::dr::set_connect_callbacks( sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); To set more than one callback to you can simply add extra callbacks to your call to `DBD::Mock::dr::set_connect_callbacks` DBD::Mock::dr::set_connect_callbacks( sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; }, sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); Or you can extend the existing set of callbacks with the `DBD::Mock::dr::add_connect_callbacks` function DBD::Mock::dr::add_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT bar FROM foo', results => [[ 'bar' ], [ 50 ]] }; } ); - table\_info This feature adds support for DBI's `table_info` method ( _Note this functionality is unstable when used with DBI version 1.634 and below_). To mock the table info for a search of the `testSchema` database schema you would use the following: $dbh->{mock_add_table_info} = { cataloge => undef, schema => 'testSchema', table => undef, type => undef, table_info => [ [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ], [ undef, 'testSchema', 'foo', 'TABLE', undef ], [ undef, 'testSchema', 'bar', 'VIEW', undef ], ], }; The `cataloge`, `schema`, `table` and `type` parameters need to explicitly match what you expect table\_info to be called with (note: `table_info` treats `undef` and `''` the same). Similar to the `mock_results_sets`, the `table_info` parameter's first entry is an arrayref of column names, and the rest are the values of the rows returned (one arrayref per row). If you need to cover listing schemas then you'd use: $dbh->{mock_add_table_info} = { schema => '%', table_info => [ [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ], [ undef, 'testSchema', undef, undef, undef ], [ undef, 'testSchema_2', undef, undef, undef ], ], } To clear the current mocked table info set the database handle's `mock_clear_table_info` attribute to `1` $dbh->{mock_clear_table_info} = 1; - Result Set Callbacks If you need your result sets to be more dynamic (e.g. if they need to return different results based upon bound parameters) then you can use a callback. $dbh->{mock_add_resultset} = { sql => 'SELECT a FROM b WHERE c = ?', callback => sub { my @bound_params = @_; my %result = ( fields => [ "a" ], rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; my $sth = $dbh->prepare('SELECT a FROM b WHERE c = ?'); my $rows = $sth->execute(1); my ($result) = $sth->fetchrow_array(); # $result will be 32 $rows = $sth->execute(2); ($result) = $sth->fetchrow_array(); # $result this time will be 43 $rows = $sth->execute(33); # $results this time will be 1 ($result) = $sth->fetchrow_array(); The callback needs to return a hash with a `rows` key that is an array ref of arrays containing the values to return as the answer to the query. In addition a `fields` key can also be returned with an array ref of field names. If a `fields` key isn't present in the returned the hash then the fields will be taken from the `mock_add_resultset`'s `results` parameter. $dbh->{mock_add_resultset} = { sql => 'SELECT x FROM y WHERE z = ?', results => [ ["x"] ], callback => sub { my @bound_params = @_; my %result = ( rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; my $sth = $dbh->prepare('SELECT x FROM y WHERE z = ?'); my $rows = $sth->execute(1); my ($result) = $sth->fetchrow_array(); # $result will be 32 $rows = $sth->execute(2); ($result) = $sth->fetchrow_array(); # $result will be 43 $rows = $sth->execute(33); ($result) = $sth->fetchrow_array(); # $result will be 1 By default result sets which only define their field names in their callback return values will have a `NUM_OF_FIELDS` property of `0` until after the statement has actually been executed. This is to make sure that `DBD::Mock` stays compatible with previous versions. If you need the `NUM_OF_FIELDS` property to be undef in this situation then set the `$DBD::Mock::DefaultFieldsToUndef` flag to `1`. # BUGS - Odd `$dbh` attribute behavior When writing the test suite I encountered some odd behavior with some `$dbh` attributes. I still need to get deeper into how DBD's work to understand what it is that is actually doing wrong. # TO DO - Make DBD specific handlers Each DBD has its own quirks and issues, it would be nice to be able to handle those issues with `DBD::Mock` in some way. I have an number of ideas already, but little time to sit down and really flesh them out. If you have any suggestions or thoughts, feel free to email me with them. - Enhance the `DBD::Mock::StatementTrack` object I would like to have the `DBD::Mock::StatementTrack` object handle more of the `mock_*` attributes. This would encapsulate much of the `mock_*` behavior in one place, which would be a good thing. # SEE ALSO [DBI](https://metacpan.org/pod/DBI) [DBD::NullP](https://metacpan.org/pod/DBD::NullP), which provided a good starting point [Test::MockObject](https://metacpan.org/pod/Test::MockObject), which provided the approach Test::MockObject article - [http://www.perl.com/pub/a/2002/07/10/tmo.html](http://www.perl.com/pub/a/2002/07/10/tmo.html) Perl Code Kata: Testing Databases - [http://www.perl.com/pub/a/2005/02/10/database\_kata.html](http://www.perl.com/pub/a/2005/02/10/database_kata.html) # ACKNOWLEDGEMENTS - Thanks to Ryan Gerry for his patch in RT #26604. - Thanks to Marc Beyer for his patch in RT #16951. - Thanks to Justin DeVuyst for the mock\_connect\_fail idea. - Thanks to Thilo Planz for the code for `bind_param_inout`. - Thanks to Shlomi Fish for help tracking down RT Bug #11515. - Thanks to Collin Winter for the patch to fix the `begin_work()`, `commit()` and `rollback()` methods. - Thanks to Andrew McHarg for `fetchall_hashref()`, `fetchrow_hashref()` and `selectcol_arrayref()` methods and tests. - Thanks to Andrew W. Gibbs for the `mock_last_insert_ids` patch and test. - Thanks to Chas Owens for patch and test for the `mock_can_prepare`, `mock_can_execute`, and `mock_can_fetch` features. - Thanks to Tomas Zemresfor the unit test in RT #71438. - Thanks to Bernhard Graf for multiple patches fixing a range of issues and adding a new _One Shot Failure_ feature to `mock_add_resultset`. # COPYRIGHT Copyright (C) 2004 Chris Winters Copyright (C) 2004-2007 Stevan Little Copyright (C) 2007 Rob Kinyon Copyright (C) 2011 Mariano Wahlmann <dichoso \_at\_ gmail.com> Copyright (C) 2019 Jason Cooper This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. # AUTHORS Chris Winters Stevan Little Rob Kinyon Mariano Wahlmann <dichoso \_at\_ gmail.com> Jason Cooper DBD-Mock-1.55/lib/0000775000000000000000000000000013602403772012176 5ustar rootrootDBD-Mock-1.55/lib/DBD/0000775000000000000000000000000013602403772012567 5ustar rootrootDBD-Mock-1.55/lib/DBD/Mock.pm0000664000175000017500000013644513602403665012256 0ustar 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.55'; 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__ =head1 NAME DBD::Mock - Mock database driver for testing =head1 SYNOPSIS use DBI; # connect to your as normal, using 'Mock' as your driver name my $dbh = DBI->connect( 'DBI:Mock:', '', '' ) || die "Cannot create handle: $DBI::errstr\n"; # create a statement handle as normal and execute with parameters my $sth = $dbh->prepare( 'SELECT this, that FROM foo WHERE id = ?' ); $sth->execute( 15 ); # Now query the statement handle as to what has been done with it my $mock_params = $sth->{mock_params}; print "Used statement: ", $sth->{mock_statement}, "\n", "Bound parameters: ", join( ', ', @{ $mock_params } ), "\n"; =head1 DESCRIPTION Testing with databases can be tricky. If you are developing a system married to a single database then you can make some assumptions about your environment and ask the user to provide relevant connection information. But if you need to test a framework that uses DBI, particularly a framework that uses different types of persistence schemes, then it may be more useful to simply verify what the framework is trying to do -- ensure the right SQL is generated and that the correct parameters are bound. C makes it easy to just modify your configuration (presumably held outside your code) and just use it instead of C (like L or L) in your framework. There is no distinct area where using this module makes sense. (Some people may successfully argue that this is a solution looking for a problem...) Indeed, if you can assume your users have something like L or L or if you do not mind creating a dependency on them then it makes far more sense to use these legitimate driver implementations and test your application in the real world -- at least as much of the real world as you can create in your tests... And if your database handle exists as a package variable or something else easily replaced at test-time then it may make more sense to use L to create a fully dynamic handle. There is an excellent article by chromatic about using L in this and other ways, strongly recommended. (See L for a link) =head2 How does it work? C comprises a set of classes used by DBI to implement a database driver. But instead of connecting to a datasource and manipulating data found there it tracks all the calls made to the database handle and any created statement handles. You can then inspect them to ensure what you wanted to happen actually happened. For instance, say you have a configuration file with your database connection information: [DBI] dsn = DBI:Pg:dbname=myapp user = foo password = bar And this file is read in at process startup and the handle stored for other procedures to use: package ObjectDirectory; my ( $DBH ); sub run_at_startup { my ( $class, $config ) = @_; $config ||= read_configuration( ... ); my $dsn = $config->{DBI}{dsn}; my $user = $config->{DBI}{user}; my $pass = $config->{DBI}{password}; $DBH = DBI->connect( $dsn, $user, $pass ) || die ...; } sub get_database_handle { return $DBH; } A procedure might use it like this (ignoring any error handling for the moment): package My::UserActions; sub fetch_user { my ( $class, $login ) = @_; my $dbh = ObjectDirectory->get_database_handle; my $sql = q{ SELECT login_name, first_name, last_name, creation_date, num_logins FROM users WHERE login_name = ? }; my $sth = $dbh->prepare( $sql ); $sth->execute( $login ); my $row = $sth->fetchrow_arrayref; return ( $row ) ? User->new( $row ) : undef; } So for the purposes of our tests we just want to ensure that: =over 4 =item 1. The right SQL is being executed =item 2. The right parameters are bound =back Assume whether the SQL actually B or not is irrelevant for this test :-) To do that our test might look like: my $config = ObjectDirectory->read_configuration( ... ); $config->{DBI}{dsn} = 'DBI:Mock:'; ObjectDirectory->run_at_startup( $config ); my $login_name = 'foobar'; my $user = My::UserActions->fetch_user( $login_name ); # Get the handle from ObjectDirectory; # this is the same handle used in the # 'fetch_user()' procedure above my $dbh = ObjectDirectory->get_database_handle(); # Ask the database handle for the history # of all statements executed against it my $history = $dbh->{mock_all_history}; # Now query that history record to # see if our expectations match reality is(scalar(@{$history}), 1, 'Correct number of statements executed' ; my $login_st = $history->[0]; like($login_st->statement, qr/SELECT login_name.*FROM users WHERE login_name = ?/sm, 'Correct statement generated' ); my $params = $login_st->bound_params; is(scalar(@{$params}), 1, 'Correct number of parameters bound'); is($params->[0], $login_name, 'Correct value for parameter 1' ); # Reset the handle for future operations $dbh->{mock_clear_history} = 1; The list of properties and what they return is listed below. But in an overall view: =over 4 =item * A database handle contains the history of all statements created against it. Other properties set for the handle (e.g., C, C) are left alone and can be queried as normal, but they do not affect anything. (A future feature may track the sequence/history of these assignments but if there is no demand it probably will not get implemented.) =item * A statement handle contains the statement it was prepared with plus all bound parameters or parameters passed via C. It can also contain predefined results for the statement handle to C, track how many fetches were called and what its current record is. =back =head2 A Word of Warning This may be an incredibly naive implementation of a DBD. But it works for me... =head1 DBD::Mock Since this is a normal DBI statement handle we need to expose our tracking information as properties (accessed like a hash) rather than methods. =head2 Database Driver Properties =over 4 =item B> This is a boolean property which when set to true (C<1>) will not allow DBI to connect. This can be used to simulate a DSN error or authentication failure. This can then be set back to false (C<0>) to resume normal DBI operations. Here is an example of how this works: # install the DBD::Mock driver my $drh = DBI->install_driver('Mock'); $drh->{mock_connect_fail} = 1; # this connection will fail my $dbh = DBI->connect('dbi:Mock:', '', '') || die "Cannot connect"; # this connection will throw an exception my $dbh = DBI->connect('dbi:Mock:', '', '', { RaiseError => 1 }); $drh->{mock_connect_fail} = 0; # this will work now ... my $dbh = DBI->connect(...); This feature is conceptually different from the C attribute of the C<$dbh> in that it has a driver-wide scope, where C is handle-wide scope. It also only prevents the initial connection, any C<$dbh> handles created prior to setting C to true (C<1>) will still go on working just fine. =item B> This is an ARRAY reference which holds fake data sources which are returned by the Driver and Database Handle's C method. =item B> This takes a string and adds it to the C attribute. =back =head2 Database Handle Properties =over 4 =item B> Returns an array reference with all history (a.k.a. C) objects created against the database handle in the order they were created. Each history object can then report information about the SQL statement used to create it, the bound parameters, etc.. =item B> Returns a C object which will iterate through the current set of C object in the history. See the L documentation below for more information. =item B> If set to a true value all previous statement history operations will be erased. This B the history of currently open handles, so if you do something like: my $dbh = get_handle( ... ); my $sth = $dbh->prepare( ... ); $dbh->{mock_clear_history} = 1; $sth->execute( 'Foo' ); You will have no way to learn from the database handle that the statement parameter 'Foo' was bound. This is useful mainly to ensure you can isolate the statement histories from each other. A typical sequence will look like: set handle to framework perform operations analyze mock database handle reset mock database handle history perform more operations analyze mock database handle reset mock database handle history ... =item B> This statement allows you to simulate a downed database connection. This is useful in testing how your application/tests will perform in the face of some kind of catastrophic event such as a network outage or database server failure. It is a simple boolean value which defaults to on, and can be set like this: # turn the database off $dbh->{mock_can_connect} = 0; # turn it back on again $dbh->{mock_can_connect} = 1; The statement handle checks this value as well, so something like this will fail in the expected way: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{mock_can_connect} = 0; # blows up! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); if ( $@ ) { # Here, $DBI::errstr = 'No connection present' } Turning off the database after a statement prepare will fail on the statement C, which is hopefully what you would expect: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); # ok! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); $dbh->{mock_can_connect} = 0; # blows up! $sth->execute; Similarly: $dbh = DBI->connect( 'DBI:Mock:', '', '' ); # ok! my $sth = eval { $dbh->prepare( 'SELECT foo FROM bar' ) }); # ok! $sth->execute; $dbh->{mock_can_connect} = 0; # blows up! my $row = $sth->fetchrow_arrayref; Note: The handle attribute C and the handle method C will behave according to the value of C. So if C were to be set to C<0> (or off), then both C and C would return false values (or C<0>). =item B> This stocks the database handle with a record set, allowing you to seed data for your application to see if it works properly. Each recordset is a simple arrayref of arrays with the first arrayref being the field names used. Every time a statement handle is created it asks the database handle if it has any resultsets available and if so uses it. Here is a sample usage, partially from the test suite: my @user_results = ( [ 'login', 'first_name', 'last_name' ], [ 'cwinters', 'Chris', 'Winters' ], [ 'bflay', 'Bobby', 'Flay' ], [ 'alincoln', 'Abe', 'Lincoln' ], ); my @generic_results = ( [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ); my $dbh = DBI->connect( 'DBI:Mock:', '', '' ); $dbh->{mock_add_resultset} = \@user_results; # add first resultset $dbh->{mock_add_resultset} = \@generic_results; # add second resultset my ( $sth ); eval { $sth = $dbh->prepare( 'SELECT login, first_name, last_name FROM foo' ); $sth->execute(); }; # this will fetch rows from the first resultset... my $row1 = $sth->fetchrow_arrayref; my $user1 = User->new( login => $row->[0], first => $row->[1], last => $row->[2] ); is( $user1->full_name, 'Chris Winters' ); my $row2 = $sth->fetchrow_arrayref; my $user2 = User->new( login => $row->[0], first => $row->[1], last => $row->[2] ); is( $user2->full_name, 'Bobby Flay' ); ... my $sth_generic = $dbh->prepare( 'SELECT foo, bar FROM baz' ); $sth_generic->execute; # this will fetch rows from the second resultset... my $row = $sth->fetchrow_arrayref; It is possible to assign a hashref where the resultset must be given as value for the C key: $dbh->{mock_add_resultset} = { results => [ [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ], }; The reason for the hashref form is that you can add options as described in the following. You can associate a resultset with a particular SQL statement instead of adding them in the order they will be fetched: $dbh->{mock_add_resultset} = { sql => 'SELECT foo, bar FROM baz', results => [ [ 'foo', 'bar' ], [ 'this_one', 'that_one' ], [ 'this_two', 'that_two' ], ], }; This will return the given results when the statement 'C statements to ensure that placeholders are bound properly. And typically you may simply want to check after the fact that a statement is syntactically correct, or at least what you expect. But other times you may want to parse the statement as it is prepared rather than after the fact. There is a hook in this mock database driver for you to provide your own parsing routine or object. The syntax is simple: $dbh->{mock_add_parser} = sub { my ( $sql ) = @_; unless ( $sql =~ /some regex/ ) { die "does not contain secret fieldname"; } }; You can also add more than one for a handle. They will be called in order, and the first one to fail will halt the parsing process: $dbh->{mock_add_parser} = \&parse_update_sql; $dbh->{mock_add-parser} = \&parse_insert_sql; Depending on the C and C settings in the database handle any parsing errors encountered will issue a C or C. No matter what the statement handle will be C. Instead of providing a subroutine reference you can use an object. The only requirement is that it implements the method C and takes a SQL statement as the only argument. So you should be able to do something like the following (untested): my $parser = SQL::Parser->new( 'mysql', { RaiseError => 1 } ); $dbh->{mock_add_parser} = $parser; =item B> & B> These properties will dispatch to the Driver's properties of the same name. =back =head2 Attribute Aliasing Basically this feature allows you to alias attributes to other attributes. So for instance, you can alias a commonly expected attribute like C to something C already has like C. While you can also just set C yourself, this functionality allows it to take advantage of things like the autoincrementing of the C attribute. The functionality is off by default so as to not cause any issues with backwards compatibility, but can easily be turned on and off like this: # turn it on $DBD::Mock::AttributeAliasing++; # turn it off $DBD::Mock::AttributeAliasing = 0; Once this is turned on, you will need to choose a database specific attribute aliasing table like so: DBI->connect('dbi:Mock:MySQL', '', ''); Or, by using the database name if using driver DSNs: DBI->connect('dbi:Mock:host=localhost;port=3306;database=MySQL', '', ''); The C in the DSN will be picked up and the MySQL specific attribute aliasing will be used. Right now there is only minimal support for MySQL and MariaDB: =over 4 =item MySQL Currently the C attribute for C<$dbh> and C<$sth> are aliased to the C<$dbh> attribute C. =item MariaDB Currently the C attribute for C<$dbh> and C<$sth> are aliased to the C<$dbh> attribute C. =back It is possible to add more aliases though, using the C function (see the source code for details) =head2 Database Driver Methods =over 4 =item B> This returns the value of C. =back In order to capture C, C, and C, C will create statements for them, as if you had issued them in the appropriate SQL command line program. They will go through the standard C-C cycle, meaning that any custom SQL parsers will be triggered and C will need to know about these statements. =over 4 =item B> This will create a statement with SQL of C and no parameters. =item B> This will create a statement with SQL of C and no parameters. =item B> This will create a statement with SQL of C and no parameters. =back =head2 Statement Handle Properties =over 4 =item B> Returns true if the handle is a C and has more records to fetch, false otherwise. (This is from the DBI, see the 'Active' docs under 'ATTRIBUTES COMMON TO ALL HANDLES'.) =item B> (Statement attribute C) Sets the state of the tracker C flag. =item B> (Statement attribute C) If set to C tells the tracker that the statement is finished. This resets the current record number to C<0> and clears out the array ref of returned records. =item B> (Statement attribute C) Returns true if the current record number is greater than the number of records set to return. =item B> Returns the number of fields set in the C parameter. =item B> Returns the number of records in the current result set. =item B> Returns the number of parameters set in the C parameter. =item B> Sets bound parameter C<$param_num> to C<$value>. Returns the arrayref of currently-set bound parameters. This corresponds to the C statement handle call. =item B> Pushes C<@params> onto the list of already-set bound parameters. =item B> Tells the tracker that the statement has been executed and resets the current record number to C<0>. =item B> If the statement has been depleted (all records returned) returns C; otherwise it gets the current record for returning, increments the current record number and returns the current record. =item B> Tries to give a decent depiction of the object state for use in debugging. =back =head1 DBD::Mock::StatementTrack::Iterator This object can be used to iterate through the current set of C objects in the history by fetching the C attribute from a database handle. This object is very simple and is meant to be a convenience to make writing long test script easier. Aside from the constructor (C) this object has the following methods. =over 4 =item B> Calling C will return the next C object in the history. If there are no more C objects available, then this method will return false. =item B> This will reset the internal pointer to the beginning of the statement history. =back =head1 DBD::Mock::Session The C object is an alternate means of specifying the SQL statements and result sets for C. The idea is that you can specify a complete 'session' of usage, which will be verified through C. Here is an example: my $session = DBD::Mock::Session->new('my_session' => ( { statement => "SELECT foo FROM bar", # as a string results => [[ 'foo' ], [ 'baz' ]] }, { statement => qr/UPDATE bar SET foo \= \'bar\'/, # as a reg-exp results => [[]] }, { statement => sub { # as a CODE ref my ($SQL, $state) = @_; return $SQL eq "SELECT foo FROM bar"; }, results => [[ 'foo' ], [ 'bar' ]] }, { # with bound parameters statement => "SELECT foo FROM bar WHERE baz = ? AND borg = ?", # check exact bound param value, # then check it against regexp bound_params => [ 10, qr/\d+/ ], results => [[ 'foo' ], [ 'baz' ]] } )); As you can see, a session is essentially made up a list of HASH references we call 'states'. Each state has a C and a set of C. If C finds a session in the C attribute, then it will pass the current C<$dbh> and SQL statement to that C. The SQL statement will be checked against the C field in the current state. If it passes, then the C of the current state will get fed to C through the C attribute. We then advance to the next state in the session, and wait for the next call through C. If at any time the SQL statement does not match the current state's C, or the session runs out of available states, an error will be raised (and propagated through the normal DBI error handling based on your values for C and C). As can be seen in the session element, bound parameters can also be supplied and tested. In this statement, the SQL is compared, then when the statement is executed, the bound parameters are also checked. The bound parameters must match in both number of parameters and the parameters themselves, or an error will be raised. As can also be seen in the example above, C fields can come in many forms. The simplest is a string, which will be compared using C against the currently running statement. The next is a reg-exp reference, this too will get compared against the currently running statement. The last option is a CODE ref, this is sort of a catch-all to allow for a wide range of SQL comparison approaches (including using modules like L or L for detailed functional comparisons). The first argument to the CODE ref will be the currently active SQL statement to compare against, the second argument is a reference to the current state HASH (in case you need to alter the results, or store extra information). The CODE is evaluated in boolean context and throws and exception if it is false. =over 4 =item B> A C<$session_name> can be optionally be specified, along with at least one C<@session_states>. If you don't specify a C<$session_name>, then a default one will be created for you. The C<@session_states> must all be HASH references as well, if this conditions fail, an exception will be thrown. =item B> This will check the C<$SQL> against the current state's C value, and if it passes will add the current state's C to the C<$dbh>. If for some reason the C value is bad, not of the prescribed type, an exception is thrown. See above for more details. =item B> If the C slot is available in the current state, this will check the C<$params> against the current state's C value. Both number of parameters and the parameters themselves must match, or an error will be raised. =item B> Calling this method will reset the state of the session object so that it can be reused. =back =head1 EXPERIMENTAL FUNCTIONALITY All functionality listed here is highly experimental and should be used with great caution (if at all). =over 4 =item Connection Callbacks This feature allows you to define callbacks that get executed when C<< DBI->connect >> is called. To set a series of callbacks you use the C function use DBD::Mock::dr; DBD::Mock::dr::set_connect_callbacks( sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); To set more than one callback to you can simply add extra callbacks to your call to C DBD::Mock::dr::set_connect_callbacks( sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; }, sub { my ( $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT foo FROM bar', results => [[ 'foo' ], [ 10 ]] }; } ); Or you can extend the existing set of callbacks with the C function DBD::Mock::dr::add_connect_callbacks( sub { ( my $dbh, $dsn, $user, $password, $attributes ) = @_; $dbh->{mock_add_resultset} = { sql => 'SELECT bar FROM foo', results => [[ 'bar' ], [ 50 ]] }; } ); =item table_info This feature adds support for DBI's C method ( I). To mock the table info for a search of the C database schema you would use the following: $dbh->{mock_add_table_info} = { cataloge => undef, schema => 'testSchema', table => undef, type => undef, table_info => [ [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ], [ undef, 'testSchema', 'foo', 'TABLE', undef ], [ undef, 'testSchema', 'bar', 'VIEW', undef ], ], }; The C, C, C and C parameters need to explicitly match what you expect table_info to be called with (note: C treats C and C<''> the same). Similar to the C, the C parameter's first entry is an arrayref of column names, and the rest are the values of the rows returned (one arrayref per row). If you need to cover listing schemas then you'd use: $dbh->{mock_add_table_info} = { schema => '%', table_info => [ [ 'TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', 'TABLE_TYPE', 'REMARKS' ], [ undef, 'testSchema', undef, undef, undef ], [ undef, 'testSchema_2', undef, undef, undef ], ], } To clear the current mocked table info set the database handle's C attribute to C<1> $dbh->{mock_clear_table_info} = 1; =item Result Set Callbacks If you need your result sets to be more dynamic (e.g. if they need to return different results based upon bound parameters) then you can use a callback. $dbh->{mock_add_resultset} = { sql => 'SELECT a FROM b WHERE c = ?', callback => sub { my @bound_params = @_; my %result = ( fields => [ "a" ], rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; my $sth = $dbh->prepare('SELECT a FROM b WHERE c = ?'); my $rows = $sth->execute(1); my ($result) = $sth->fetchrow_array(); # $result will be 32 $rows = $sth->execute(2); ($result) = $sth->fetchrow_array(); # $result this time will be 43 $rows = $sth->execute(33); # $results this time will be 1 ($result) = $sth->fetchrow_array(); The callback needs to return a hash with a C key that is an array ref of arrays containing the values to return as the answer to the query. In addition a C key can also be returned with an array ref of field names. If a C key isn't present in the returned the hash then the fields will be taken from the C's C parameter. $dbh->{mock_add_resultset} = { sql => 'SELECT x FROM y WHERE z = ?', results => [ ["x"] ], callback => sub { my @bound_params = @_; my %result = ( rows => [[ 1] ] ); if ($bound_params[0] == 1) { $result{rows} = [ [32] ]; } elsif ($bound_params[0] == 2) { $result{rows} = [ [43] ]; } return %result; }, }; my $sth = $dbh->prepare('SELECT x FROM y WHERE z = ?'); my $rows = $sth->execute(1); my ($result) = $sth->fetchrow_array(); # $result will be 32 $rows = $sth->execute(2); ($result) = $sth->fetchrow_array(); # $result will be 43 $rows = $sth->execute(33); ($result) = $sth->fetchrow_array(); # $result will be 1 By default result sets which only define their field names in their callback return values will have a C property of C<0> until after the statement has actually been executed. This is to make sure that C stays compatible with previous versions. If you need the C property to be undef in this situation then set the C<$DBD::Mock::DefaultFieldsToUndef> flag to C<1>. =back =head1 BUGS =over =item Odd C<$dbh> attribute behavior When writing the test suite I encountered some odd behavior with some C<$dbh> attributes. I still need to get deeper into how DBD's work to understand what it is that is actually doing wrong. =back =head1 TO DO =over =item Make DBD specific handlers Each DBD has its own quirks and issues, it would be nice to be able to handle those issues with C in some way. I have an number of ideas already, but little time to sit down and really flesh them out. If you have any suggestions or thoughts, feel free to email me with them. =item Enhance the C object I would like to have the C object handle more of the C attributes. This would encapsulate much of the C behavior in one place, which would be a good thing. =back =head1 SEE ALSO L L, which provided a good starting point L, which provided the approach Test::MockObject article - L Perl Code Kata: Testing Databases - L =head1 ACKNOWLEDGEMENTS =over 4 =item Thanks to Ryan Gerry for his patch in RT #26604. =item Thanks to Marc Beyer for his patch in RT #16951. =item Thanks to Justin DeVuyst for the mock_connect_fail idea. =item Thanks to Thilo Planz for the code for C. =item Thanks to Shlomi Fish for help tracking down RT Bug #11515. =item Thanks to Collin Winter for the patch to fix the C, C and C methods. =item Thanks to Andrew McHarg Eamcharg@acm.orgE for C, C and C methods and tests. =item Thanks to Andrew W. Gibbs for the C patch and test. =item Thanks to Chas Owens for patch and test for the C, C, and C features. =item Thanks to Tomas Zemresfor the unit test in RT #71438. =item Thanks to Bernhard Graf for multiple patches fixing a range of issues and adding a new I feature to C. =back =head1 COPYRIGHT Copyright (C) 2004 Chris Winters Echris@cwinters.comE Copyright (C) 2004-2007 Stevan Little Estevan@iinteractive.comE Copyright (C) 2007 Rob Kinyon Erob.kinyon@gmail.comE Copyright (C) 2011 Mariano Wahlmann Edichoso _at_ gmail.comE Copyright (C) 2019 Jason Cooper EJLCOOPER@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 AUTHORS Chris Winters Echris@cwinters.comE Stevan Little Estevan@iinteractive.comE Rob Kinyon Erob.kinyon@gmail.comE Mariano Wahlmann Edichoso _at_ gmail.comE Jason Cooper EJLCOOPER@cpan.orgE =cut DBD-Mock-1.55/lib/DBD/Mock/0000775000000000000000000000000013602403772013460 5ustar rootrootDBD-Mock-1.55/lib/DBD/Mock/db.pm0000664000175000017500000003452413602403665012636 0ustar 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); 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}; } else { $rs = shift @{ $all_rs->{ordered} }; if (ref($rs) eq 'HASH') { $callback = $rs->{callback}; $failure = $rs->{failure}; $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; 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, }; } elsif ( ref $name eq "Regexp" ) { my $matching = { regexp => $name, results => \@copied_values, callback => $value->{callback}, failure => ref($value->{failure}) ? [ @{ $value->{failure} } ] : undef, }; # 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, }; } } 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; DBD-Mock-1.55/lib/DBD/Mock/dr.pm0000644000175000017500000000713513602403665012652 0ustar package DBD::Mock::dr; use strict; use warnings; use List::Util qw(reduce); our $imp_data_size = 0; my @connect_callbacks; 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 ||= {}; my %driverParameters = _parse_driver_dsn( $dbname ); if ( $dbname && $DBD::Mock::AttributeAliasing ) { # this is the DB we are mocking $attributes->{mock_attribute_aliases} = DBD::Mock::_get_mock_attribute_aliases($driverParameters{database}); $attributes->{mock_database_name} = $driverParameters{database}; } # 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; foreach my $callback (@connect_callbacks) { $callback->( $dbh, $dbname, $user, $auth, $attributes ); } 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 } sub set_connect_callbacks { @connect_callbacks = map { die "connect callbacks needs to be a reference to a function " unless ref $_ eq "CODE"; $_ } @_; } sub add_connect_callbacks { push @connect_callbacks, map { die "connect callbacks needs to be a reference to a function " unless ref $_ eq "CODE"; $_ } @_; } sub _parse_driver_dsn { my ( $driverDsn ) = @_; $driverDsn = $driverDsn ? $driverDsn : ''; my %driverParameters; foreach my $parameter ( split /;/, $driverDsn ) { if ( my ( $key, $value ) = $parameter =~ m/^(.*?)=(.*)$/ ) { $driverParameters{ $key } = $value; } } $driverParameters{database} = $driverDsn unless %driverParameters; return %driverParameters; } 1; DBD-Mock-1.55/lib/DBD/Mock/st.pm0000644000175000017500000003123013602403665012664 0ustar package DBD::Mock::st; use strict; use warnings; our $imp_data_size = 0; sub bind_col { my ( $sth, $param_num, $ref, $attr ) = @_; my $tracker = $sth->FETCH('mock_my_history'); $tracker->bind_col( $param_num, $ref ); return 1; } sub bind_param { my ( $sth, $param_num, $val, $attr ) = @_; my $tracker = $sth->FETCH('mock_my_history'); $tracker->bound_param( $param_num, $val, $attr ); return 1; } sub bind_param_array { bind_param(@_); } sub bind_param_inout { my ( $sth, $param_num, $val, $max_len ) = @_; # check that $val is a scalar ref ( UNIVERSAL::isa( $val, 'SCALAR' ) ) || $sth->{Database} ->set_err( 1, "need a scalar ref to bind_param_inout, not $val" ); # check for positive $max_len ( $max_len > 0 ) || $sth->{Database} ->set_err( 1, "need to specify a maximum length to bind_param_inout" ); my $tracker = $sth->FETCH('mock_my_history'); $tracker->bound_param( $param_num, $val ); 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}; unless ( $dbh->{mock_can_connect} ) { $dbh->set_err( 1, "No connection present" ); return 0; } unless ( $dbh->{mock_can_execute} ) { $dbh->set_err( 1, "Cannot execute" ); return 0; } $dbh->{mock_can_execute}++ if $dbh->{mock_can_execute} < 0; my $tracker = $sth->FETCH('mock_my_history'); if ( $tracker->has_failure() ) { $dbh->set_err( $tracker->get_failure() ); return 0; } if (@params) { $tracker->bind_params(@params); } if ( my $session = $dbh->{mock_session} ) { eval { my $state = $session->current_state; $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 my @results = @{ $state->{results} }; shift @results; $tracker->{return_data} = \@results; }; if ($@) { my $session_error = $@; chomp $session_error; $sth->set_err( 1, "Session Error: ${session_error}" ); return; } } $tracker->mark_executed; my $fields = $tracker->fields; $sth->STORE( NUM_OF_FIELDS => scalar @{ $fields ? $fields : [] } ); $sth->STORE( NAME => $fields ); $sth->STORE( NUM_OF_PARAMS => $tracker->num_params ); # handle INSERT statements and the mock_last_insert_ids # We should only increment these things after the last successful INSERT. # -RobK, 2007-10-12 #use Data::Dumper;warn Dumper $dbh->{mock_last_insert_ids}; if ( $dbh->{Statement} =~ /^\s*?insert(?:\s+ignore)?\s+into\s+(\S+)/i ) { if ( $dbh->{mock_last_insert_ids} && exists $dbh->{mock_last_insert_ids}{$1} ) { $dbh->{mock_last_insert_id} = $dbh->{mock_last_insert_ids}{$1}++; } else { $dbh->{mock_last_insert_id}++; } } #warn "$dbh->{mock_last_insert_id}\n"; # always return 0E0 for Selects if ( $dbh->{Statement} =~ /^\s*?select/i ) { return '0E0'; } return ( $sth->rows() || '0E0' ); } sub fetch { my ($sth) = @_; my $dbh = $sth->{Database}; unless ( $dbh->{mock_can_connect} ) { $dbh->set_err( 1, "No connection present" ); return; } unless ( $dbh->{mock_can_fetch} ) { $dbh->set_err( 1, "Cannot fetch" ); return; } $dbh->{mock_can_fetch}++ if $dbh->{mock_can_fetch} < 0; my $tracker = $sth->FETCH('mock_my_history'); my $record = $tracker->next_record or return; if ( my @cols = $tracker->bind_cols() ) { for my $i ( grep { ref $cols[$_] } 0 .. $#cols ) { ${ $cols[$i] } = $record->[$i]; } } return $record; } sub fetchrow_array { my ($sth) = @_; my $row = $sth->DBD::Mock::st::fetch(); return unless ref($row) eq 'ARRAY'; return @{$row}; } sub fetchrow_arrayref { my ($sth) = @_; return $sth->DBD::Mock::st::fetch(); } sub fetchrow_hashref { my ( $sth, $name ) = @_; my $dbh = $sth->{Database}; # handle any errors since we are grabbing # from the tracker directly unless ( $dbh->{mock_can_connect} ) { $dbh->set_err( 1, "No connection present" ); return; } unless ( $dbh->{mock_can_fetch} ) { $dbh->set_err( 1, "Cannot fetch" ); return; } $dbh->{mock_can_fetch}++ if $dbh->{mock_can_fetch} < 0; # first handle the $name, it will default to NAME $name ||= 'NAME'; # then fetch the names from the $sth (per DBI spec) my $fields = $sth->FETCH($name); # now check the tracker ... my $tracker = $sth->FETCH('mock_my_history'); # and collect the results if ( my $record = $tracker->next_record() ) { my @values = @{$record}; return { map { $_ => shift(@values) } @{$fields} }; } return undef; } #XXX Isn't this supposed to return an array of hashrefs? -RobK, 2007-10-15 sub fetchall_hashref { my ( $sth, $keyfield ) = @_; my $dbh = $sth->{Database}; # handle any errors since we are grabbing # from the tracker directly unless ( $dbh->{mock_can_connect} ) { $dbh->set_err( 1, "No connection present" ); return; } unless ( $dbh->{mock_can_fetch} ) { $dbh->set_err( 1, "Cannot fetch" ); return; } $dbh->{mock_can_fetch}++ if $dbh->{mock_can_fetch} < 0; # get the case conversion to use for hash key names (NAME/NAME_lc/NAME_uc) my $hash_key_name = $sth->{Database}->FETCH('FetchHashKeyName') || 'NAME'; # get a hashref mapping field names to their corresponding indexes. indexes # start at zero my $names_hash = $sth->FETCH("${hash_key_name}_hash"); # as of DBI v1.48, the $keyfield argument can be either an arrayref of field # names/indexes or a single field name/index my @key_fields = ref $keyfield ? @{$keyfield} : $keyfield; my $num_fields = $sth->FETCH('NUM_OF_FIELDS'); # get the index(es) of the given key field(s). a key field can be specified # as either the name of a field or an integer column number my @key_indexes; foreach my $field (@key_fields) { if (defined $names_hash->{$field}) { push @key_indexes, $names_hash->{$field}; } elsif (DBI::looks_like_number($field) && $field >= 1 && $field <= $num_fields) { # convert from column number to array index. column numbers start at # one, while indexes start at zero push @key_indexes, $field - 1; } else { my $err = "Could not find key field '$field' (not one of " . join(' ', keys %{$names_hash}) . ')'; $dbh->set_err( 1, $err ); return; } } my $tracker = $sth->FETCH('mock_my_history'); my $rethash = {}; # now loop through all the records ... while ( my $record = $tracker->next_record() ) { # populate the hash, adding a layer of nesting for each key field # specified by the user my $ref = $rethash; foreach my $index (@key_indexes) { my $value = $record->[$index]; $ref->{$value} = {} if ! defined $ref->{$value}; $ref = $ref->{$value}; } # copy all of the returned data into the most-nested level of the hash foreach my $field (keys %{$names_hash}) { my $index = $names_hash->{$field}; $ref->{$field} = $record->[$index]; } } return $rethash; } sub finish { my ($sth) = @_; $sth->FETCH('mock_my_history')->is_finished('yes'); } sub rows { my ($sth) = @_; $sth->FETCH('mock_num_rows'); } sub FETCH { my ( $sth, $attrib ) = @_; $sth->trace_msg("Fetching ST attribute '$attrib'\n"); my $tracker = $sth->{mock_my_history}; $sth->trace_msg( "Retrieved tracker: " . ref($tracker) . "\n" ); # NAME attributes if ( $attrib eq 'NAME' ) { return [ @{ $tracker->fields } ]; } elsif ( $attrib eq 'NAME_lc' ) { return [ map { lc($_) } @{ $tracker->fields } ]; } elsif ( $attrib eq 'NAME_uc' ) { return [ map { uc($_) } @{ $tracker->fields } ]; } # NAME_hash attributes elsif ( $attrib eq 'NAME_hash' ) { my $i = 0; return { map { $_ => $i++ } @{ $tracker->fields } }; } elsif ( $attrib eq 'NAME_hash_lc' ) { my $i = 0; return { map { lc($_) => $i++ } @{ $tracker->fields } }; } elsif ( $attrib eq 'NAME_hash_uc' ) { my $i = 0; return { map { uc($_) => $i++ } @{ $tracker->fields } }; } # others elsif ( $attrib eq 'NUM_OF_FIELDS' ) { return $tracker->num_fields; } elsif ( $attrib eq 'NUM_OF_PARAMS' ) { return $tracker->num_params; } elsif ( $attrib eq 'TYPE' ) { my $num_fields = $tracker->num_fields; return [ map { $DBI::SQL_VARCHAR } ( 0 .. $num_fields ) ]; } elsif ( $attrib eq 'Active' ) { return $tracker->is_active; } elsif ( $attrib !~ /^mock/ ) { if ( $sth->{Database}->{mock_attribute_aliases} ) { if ( exists ${ $sth->{Database}->{mock_attribute_aliases}->{st} } {$attrib} ) { my $mock_attrib = $sth->{Database}->{mock_attribute_aliases}->{st}->{$attrib}; if ( ref($mock_attrib) eq 'CODE' ) { return $mock_attrib->($sth); } else { return $sth->FETCH($mock_attrib); } } } return $sth->SUPER::FETCH($attrib); } # now do our stuff... if ( $attrib eq 'mock_my_history' ) { return $tracker; } elsif ( $attrib eq 'mock_execution_history' ) { return $tracker->execution_history(); } elsif ( $attrib eq 'mock_statement' ) { return $tracker->statement; } elsif ( $attrib eq 'mock_params' ) { return $tracker->bound_params; } elsif ( $attrib eq 'mock_param_attrs' ) { return $tracker->bound_param_attrs; } elsif ( $attrib eq 'mock_records' ) { return $tracker->return_data; } elsif ( $attrib eq 'mock_num_records' || $attrib eq 'mock_num_rows' ) { return $tracker->num_rows; } elsif ( $attrib eq 'mock_current_record_num' ) { return $tracker->current_record_num; } elsif ( $attrib eq 'mock_fields' ) { return $tracker->fields; } elsif ( $attrib eq 'mock_is_executed' ) { return $tracker->is_executed; } elsif ( $attrib eq 'mock_is_finished' ) { return $tracker->is_finished; } elsif ( $attrib eq 'mock_is_depleted' ) { return $tracker->is_depleted; } else { die "I don't know how to retrieve statement attribute '$attrib'\n"; } } sub STORE { my ( $sth, $attrib, $value ) = @_; $sth->trace_msg("Storing ST attribute '$attrib'\n"); if ( $attrib =~ /^mock/ ) { return $sth->{$attrib} = $value; } elsif ( $attrib =~ /^NAME/ ) { # no-op... return; } else { $value ||= 0; return $sth->SUPER::STORE( $attrib, $value ); } } sub DESTROY { undef } 1; DBD-Mock-1.55/lib/DBD/Mock/Pool.pm0000644000175000017500000000056413602403665013155 0ustar 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; DBD-Mock-1.55/lib/DBD/Mock/StatementTrack/0000775000000000000000000000000013602403772016411 5ustar rootrootDBD-Mock-1.55/lib/DBD/Mock/StatementTrack/Iterator.pm0000644000175000017500000000062413602403665016763 0ustar 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; DBD-Mock-1.55/lib/DBD/Mock/Pool/0000775000000000000000000000000013602403772014371 5ustar rootrootDBD-Mock-1.55/lib/DBD/Mock/Pool/db.pm0000644000175000017500000000015313602403665013534 0ustar package DBD::Mock::Pool::db; use strict; use warnings; our @ISA = qw(DBI::db); sub disconnect { 1 } 1; DBD-Mock-1.55/lib/DBD/Mock/StatementTrack.pm0000644000175000017500000001317413602403665015176 0ustar 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} ||= $DBD::Mock::DefaultFieldsToUndef ? undef : []; $params{bound_params} ||= []; $params{bound_param_attrs} ||= []; $params{statement} ||= ""; $params{failure} ||= undef; $params{callback} ||= 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 $self->{fields} ? scalar @{ $self->{fields} } : $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, $attr ) = @_; # Basic support for named parameters if ( $param_num !~ /^\d+/ ) { $param_num = $self->num_params + 1; } $self->{bound_params}->[ $param_num - 1 ] = $value; $self->{bound_param_attrs}->[ $param_num - 1 ] = ref $attr eq "HASH" ? { %$attr } : $attr; 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; @{ $self->{bound_param_attrs} } = map { undef } @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) = @_; push @{$self->{execution_history} }, { params => [ @{ $self->{bound_params} } ], attrs => [ @{ $self->{bound_param_attrs} } ], }; $self->is_executed('yes'); $self->current_record_num(0); if (ref $self->{callback} eq "CODE") { my %recordSet = $self->{callback}->(@{ $self->{bound_params} }); if (ref $recordSet{fields} eq "ARRAY") { $self->{fields} = $recordSet{fields}; } if (ref $recordSet{rows} eq "ARRAY") { $self->{return_data} = $recordSet{rows}; } } } 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}; } sub callback { my ( $self, $callback ) = @_; $self->{callback} = $callback if defined $callback; return $self->{callback}; } # 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 ) = @_; $self->{fields} ||= []; 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}; } sub bound_param_attrs { my ( $self, @values ) = @_; push @{ $self->{bound_param_attrs} }, @values if scalar @values; return $self->{bound_param_attrs}; } sub execution_history { my ( $self, @values ) = @_; push @{ $self->{execution_history} }, @values if scalar @values; return $self->{execution_history}; } 1; DBD-Mock-1.55/lib/DBD/Mock/Session.pm0000644000175000017500000001116613602403665013667 0ustar package DBD::Mock::Session; use strict; use warnings; my $INSTANCE_COUNT = 1; # - Class - # sub new { my $class = shift; my $name = ref( $_[0] ) ? "Session $INSTANCE_COUNT" : shift; $INSTANCE_COUNT++; $class->_verify_states( $name, @_ ); bless { name => $name, states => \@_, state_index => 0 }, $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 ); } } # - Instance - # sub name { my $self = shift; $self->{name}; } sub reset { my $self = shift; $self->{state_index} = 0; } 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} < $self->_num_states; } sub verify_statement { my ( $self, $got ) = @_; unless ( $self->has_states_left ) { die "Session states exhausted, only '" . $self->_num_states . "' in DBD::Mock::Session ($self->name})"; } my $state = $self->current_state; my $expected = $state->{statement}; my $ref = ref($expected); 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", } 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})"; } 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"; } } sub results_for { my ( $self, $statment ) = @_; $self->_find_state_for($statment)->{results}; } sub verify_bound_params { my ( $self, $params ) = @_; my $current_state = $self->current_state; if ( exists ${$current_state}{bound_params} ) { my $expected = $current_state->{bound_params}; 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 # the next statement $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' ) { if ( $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"; } } elsif ( $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; DBD-Mock-1.55/META.yml0000664000175000017500000000344613602403665011133 0ustar --- abstract: 'Mock database driver for testing' author: - 'Chris Winters ' - 'Stevan Little ' - 'Rob Kinyon ' - 'Mariano Wahlmann ' - 'Jason Cooper ' build_requires: Test::Exception: '0.31' Test::More: '0.47' configure_requires: Module::Build::Tiny: '0.035' dynamic_config: 0 generated_by: 'Minilla/v3.1.6, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBD-Mock no_index: directory: - t - xt - inc - share - eg - examples - author - builder provides: DBD::Mock: file: lib/DBD/Mock.pm version: '1.55' DBD::Mock::Pool: file: lib/DBD/Mock/Pool.pm DBD::Mock::Pool::db: file: lib/DBD/Mock/Pool/db.pm DBD::Mock::Session: file: lib/DBD/Mock/Session.pm DBD::Mock::StatementTrack: file: lib/DBD/Mock/StatementTrack.pm DBD::Mock::StatementTrack::Iterator: file: lib/DBD/Mock/StatementTrack/Iterator.pm DBD::Mock::db: file: lib/DBD/Mock/db.pm DBD::Mock::dr: file: lib/DBD/Mock/dr.pm DBD::Mock::st: file: lib/DBD/Mock/st.pm requires: DBI: '1.3' List::Util: '1.27' perl: '5.008001' resources: homepage: https://gitlab.com/scrapheap/DBD-Mock repository: git://gitlab.com/scrapheap/DBD-Mock.git version: '1.55' x_authority: cpan:JLCOOPER x_contributors: - 'Bernhard Graf ' - 'Chisel ' - 'Dave Rolsky ' - 'Frédéric Brière ' - 'Gines R ' - 'Max Carey ' - 'gregor herrmann ' - 'wu-lee ' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_static_install: 1 DBD-Mock-1.55/minil.toml0000644000175000017500000000053013602403665011654 0ustar name = "DBD-Mock" authors = [ "Chris Winters ", "Stevan Little ", "Rob Kinyon ", "Mariano Wahlmann ", "Jason Cooper ", ] authority = "cpan:JLCOOPER" module_maker = "ModuleBuildTiny" static_install = "auto" no_github_issues = true