path: root/t/02dbidrv.t

#!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;