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;