diff options
Diffstat (limited to 't/02dbidrv.t')
-rwxr-xr-x | t/02dbidrv.t | 254 |
1 files changed, 254 insertions, 0 deletions
diff --git a/t/02dbidrv.t b/t/02dbidrv.t new file mode 100755 index 0000000..7a80ffe --- /dev/null +++ b/t/02dbidrv.t @@ -0,0 +1,254 @@ +#!perl -w +# vim:sw=4:ts=8:et +$|=1; + +use strict; + +use Test::More tests => 53; + +## ---------------------------------------------------------------------------- +## 02dbidrv.t - ... +## ---------------------------------------------------------------------------- +# This test creates a Test Driver (DBD::Test) and then exercises it. +# NOTE: +# There are a number of tests as well that are embedded within the actual +# driver code as well +## ---------------------------------------------------------------------------- + +## load DBI + +BEGIN { + use_ok('DBI'); +} + +## ---------------------------------------------------------------------------- +## create a Test Driver (DBD::Test) + +## main Test Driver Package +{ + package DBD::Test; + + use strict; + use warnings; + + my $drh = undef; + + sub driver { + return $drh if $drh; + + Test::More::pass('... DBD::Test->driver called to getnew Driver handle'); + + my($class, $attr) = @_; + $class = "${class}::dr"; + ($drh) = DBI::_new_drh($class, { + Name => 'Test', + Version => '$Revision: 11.11 $', + }, + 77 # 'implementors data' + ); + + Test::More::ok($drh, "... new Driver handle ($drh) created successfully"); + Test::More::isa_ok($drh, 'DBI::dr'); + + return $drh; + } +} + +## Test Driver +{ + package DBD::Test::dr; + + use strict; + use warnings; + + $DBD::Test::dr::imp_data_size = 0; + + Test::More::cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo'); + + sub DESTROY { undef } + + sub data_sources { + my ($h) = @_; + + Test::More::ok($h, '... Driver object passed to data_sources'); + Test::More::isa_ok($h, 'DBI::dr'); + Test::More::ok(!tied $h, '... Driver object is not tied'); + + return ("dbi:Test:foo", "dbi:Test:bar"); + } +} + +## Test db package +{ + package DBD::Test::db; + + use strict; + + $DBD::Test::db::imp_data_size = 0; + + Test::More::cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo'); + + sub do { + my $h = shift; + + Test::More::ok($h, '... Database object passed to do'); + Test::More::isa_ok($h, 'DBI::db'); + Test::More::ok(!tied $h, '... Database object is not tied'); + + my $drh_i = $h->{Driver}; + + Test::More::ok($drh_i, '... got Driver object from Database object with Driver attribute'); + Test::More::isa_ok($drh_i, "DBI::dr"); + Test::More::ok(!tied %{$drh_i}, '... Driver object is not tied'); + + my $drh_o = $h->FETCH('Driver'); + + Test::More::ok($drh_o, '... got Driver object from Database object by FETCH-ing Driver attribute'); + Test::More::isa_ok($drh_o, "DBI::dr"); + SKIP: { + Test::More::skip "running DBI::PurePerl", 1 if $DBI::PurePerl; + Test::More::ok(tied %{$drh_o}, '... Driver object is not tied'); + } + + # return this to make our test pass + return 1; + } + + sub data_sources { + my ($dbh, $attr) = @_; + my @ds = $dbh->SUPER::data_sources($attr); + + Test::More::is_deeply(( + \@ds, + [ 'dbi:Test:foo', 'dbi:Test:bar' ] + ), + '... checking fetched datasources from Driver' + ); + + push @ds, "dbi:Test:baz"; + return @ds; + } + + sub disconnect { + shift->STORE(Active => 0); + } +} + +## ---------------------------------------------------------------------------- +## test the Driver (DBD::Test) + +$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver() + +# Note that install_driver should *not* normally be called directly. +# This test does so only because it's a test of install_driver! + +my $drh = DBI->install_driver('Test'); + +ok($drh, '... got a Test Driver object back from DBI->install_driver'); +isa_ok($drh, 'DBI::dr'); + +cmp_ok(DBI::_get_imp_data($drh), '==', 77, '... checking the DBI::_get_imp_data function'); + +my @ds1 = DBI->data_sources("Test"); +is_deeply(( + [ @ds1 ], + [ 'dbi:Test:foo', 'dbi:Test:bar' ] + ), '... got correct datasources from DBI->data_sources("Test")' +); + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids'); +} + +# create scope to test $dbh DESTROY behaviour +do { + + my $dbh = $drh->connect; + + ok($dbh, '... got a database handle from calling $drh->connect'); + isa_ok($dbh, 'DBI::db'); + + SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 1, '... this Driver does not yet have any Kids'); + } + + my @ds2 = $dbh->data_sources(); + is_deeply(( + [ @ds2 ], + [ 'dbi:Test:foo', 'dbi:Test:bar', 'dbi:Test:baz' ] + ), '... got correct datasources from $dbh->data_sources()' + ); + + ok($dbh->do('dummy'), '... this will trigger more driver internal tests above in DBD::Test::db'); + + $dbh->disconnect; + + $drh->set_err("41", "foo 41 drh"); + cmp_ok($drh->err, '==', 41, '... checking Driver handle err set with set_err method'); + $dbh->set_err("42", "foo 42 dbh"); + cmp_ok($dbh->err, '==', 42, '... checking Database handle err set with set_err method'); + cmp_ok($drh->err, '==', 41, '... checking Database handle err set with Driver handle set_err method'); + +}; + +SKIP: { + skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl; + + cmp_ok($drh->{Kids}, '==', 0, '... this Driver does not yet have any Kids') + or $drh->dump_handle("bad Kids",3); +} + +# copied up to drh from dbh when dbh was DESTROYd +cmp_ok($drh->err, '==', 42, '... $dbh->DESTROY should set $drh->err to 42'); + +$drh->set_err("99", "foo"); +cmp_ok($DBI::err, '==', 99, '... checking $DBI::err set with Driver handle set_err method'); +is($DBI::errstr, "foo 42 dbh [err was 42 now 99]\nfoo", '... checking $DBI::errstr'); + +$drh->default_user("",""); # just to reset err etc +$drh->set_err(1, "errmsg", "00000"); +is($DBI::state, "", '... checking $DBI::state'); + +$drh->set_err(1, "test error 1"); +is($DBI::state, 'S1000', '... checking $DBI::state'); + +$drh->set_err(2, "test error 2", "IM999"); +is($DBI::state, 'IM999', '... checking $DBI::state'); + +SKIP: { + skip "using DBI::PurePerl", 1 if $DBI::PurePerl; + eval { + $DBI::rows = 1 + }; + like($@, qr/Can't modify/, '... trying to assign to $DBI::rows should throw an excpetion'); #' +} + +is($drh->{FetchHashKeyName}, 'NAME', '... FetchHashKeyName is NAME'); +$drh->{FetchHashKeyName} = 'NAME_lc'; +is($drh->{FetchHashKeyName}, 'NAME_lc', '... FetchHashKeyName is now changed to NAME_lc'); + +ok(!$drh->disconnect_all, '... calling $drh->disconnect_all (not implemented but will fail silently)'); + +ok defined $drh->dbixs_revision, 'has dbixs_revision'; +ok($drh->dbixs_revision =~ m/^\d+$/, 'has integer dbixs_revision'); + +SKIP: { + skip "using DBI::PurePerl", 5 if $DBI::PurePerl; + my $can = $drh->can('FETCH'); + + ok($can, '... $drh can FETCH'); + is(ref($can), "CODE", '... and it returned a proper CODE ref'); + + my $name = $can->($drh, "Name"); + + ok($name, '... used FETCH returned from can to fetch the Name attribute'); + is($name, "Test", '... the Name attribute is equal to Test'); + + ok(!$drh->can('disconnect_all'), '... '); +} + +1; |