#!perl -w
use strict;
use Storable qw(dclone);
use Test::More;
## ----------------------------------------------------------------------------
## 06attrs.t - ...
## ----------------------------------------------------------------------------
# This test checks the parameters and the values associated with them for 
# the three different handles (Driver, Database, Statement)
## ----------------------------------------------------------------------------
BEGIN { 
        use_ok( 'DBI' ) 
}
$|=1;
my $using_autoproxy = ($ENV{DBI_AUTOPROXY});
my $dsn = 'dbi:ExampleP:dummy';
# Connect to the example driver.
my $dbh = DBI->connect($dsn, '', '', { 
    PrintError => 0, RaiseError => 1,
});
isa_ok( $dbh, 'DBI::db' );
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
## ----------------------------------------------------------------------------
# Check the database handle attributes.
#       bit flag attr
ok( $dbh->{Warn},               '... checking Warn attribute for dbh');
ok( $dbh->{Active},             '... checking Active attribute for dbh');
ok( $dbh->{AutoCommit},         '... checking AutoCommit attribute for dbh');
ok(!$dbh->{CompatMode},         '... checking CompatMode attribute for dbh');
ok(!$dbh->{InactiveDestroy},    '... checking InactiveDestroy attribute for dbh');
ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for dbh');
ok(!$dbh->{PrintError},         '... checking PrintError attribute for dbh');
ok( $dbh->{PrintWarn},          '... checking PrintWarn attribute for dbh'); # true because of perl -w above
ok( $dbh->{RaiseError},         '... checking RaiseError attribute for dbh');
ok(!$dbh->{RaiseWarn},          '... checking RaiseWarn attribute for dbh');
ok(!$dbh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for dbh');
ok(!$dbh->{ChopBlanks},         '... checking ChopBlanks attribute for dbh');
ok(!$dbh->{LongTruncOk},        '... checking LongTrunkOk attribute for dbh');
ok(!$dbh->{TaintIn},            '... checking TaintIn attribute for dbh');
ok(!$dbh->{TaintOut},           '... checking TaintOut attribute for dbh');
ok(!$dbh->{Taint},              '... checking Taint attribute for dbh');
ok(!$dbh->{Executed},           '... checking Executed attribute for dbh');
#       other attr
cmp_ok($dbh->{ErrCount}, '==', 0, '... checking ErrCount attribute for dbh');
SKIP: {
    skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
     
    cmp_ok($dbh->{Kids},       '==', 0, '... checking Kids attribute for dbh');;
    cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for dbh');;
}
is($dbh->{CachedKids}, undef,     '... checking CachedKids attribute for dbh');
ok(!defined $dbh->{HandleError},  '... checking HandleError attribute for dbh');
ok(!defined $dbh->{Profile},      '... checking Profile attribute for dbh');
ok(!defined $dbh->{Statement},    '... checking Statement attribute for dbh');
ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for dbh');
ok(!defined $dbh->{ReadOnly},     '... checking ReadOnly attribute for dbh');
is($dbh->{FetchHashKeyName}, 'NAME',  '... checking FetchHashKeyName attribute for dbh');
is($dbh->{Name},             'dummy', '... checking Name attribute for dbh') # fails for Multiplex
    unless $using_autoproxy && ok(1);
cmp_ok($dbh->{TraceLevel},  '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for dbh');
cmp_ok($dbh->{LongReadLen}, '==', 80,                    '... checking LongReadLen attribute for dbh');
is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCount)) ],
          [ undef, qw(NAME 80 0) ], 'should be able to FETCH_many';
is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value';
is delete $dbh->{examplep_private_dbh_attrib}, 42, 'delete on non-private attribute acts like fetch';
is $dbh->{examplep_private_dbh_attrib}, 42, 'value unchanged after delete';
$dbh->{private_foo} = 42;
is $dbh->{private_foo}, 42, 'should see private_foo dbh attribute value';
is delete $dbh->{private_foo}, 42, 'delete should return private_foo dbh attribute value';
is $dbh->{private_foo}, undef, 'value of private_foo after delete should be undef';
# Raise an error.
eval { 
    $dbh->do('select foo from foo') 
};
like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching exception');
ok(defined $dbh->err, '... $dbh->err is undefined');
like($dbh->errstr,  qr/^Unknown field names: foo\b/, '... checking $dbh->errstr');
is($dbh->state, 'S1000', '... checking $dbh->state');
ok($dbh->{Executed}, '... checking Executed attribute for dbh');    # even though it failed
$dbh->{Executed} = 0;                                    # reset(able)
cmp_ok($dbh->{Executed}, '==', 0, '... checking Executed attribute for dbh (after reset)');
cmp_ok($dbh->{ErrCount}, '==', 1, '... checking ErrCount attribute for dbh (after error was generated)');
## ----------------------------------------------------------------------------
# Test the driver handle attributes.
my $drh = $dbh->{Driver};
isa_ok( $drh, 'DBI::dr' );
ok($dbh->err, '... checking $dbh->err');
cmp_ok($drh->{ErrCount}, '==', 0, '... checking ErrCount attribute for drh');
ok( $drh->{Warn},               '... checking Warn attribute for drh');
ok( $drh->{Active},             '... checking Active attribute for drh');
ok( $drh->{AutoCommit},         '... checking AutoCommit attribute for drh');
ok(!$drh->{CompatMode},         '... checking CompatMode attribute for drh');
ok(!$drh->{InactiveDestroy},    '... checking InactiveDestroy attribute for drh');
ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for drh');
ok(!$drh->{PrintError},         '... checking PrintError attribute for drh');
ok( $drh->{PrintWarn},          '... checking PrintWarn attribute for drh'); # true because of perl -w above
ok(!$drh->{RaiseError},         '... checking RaiseError attribute for drh');
ok(!$dbh->{RaiseWarn},          '... checking RaiseWarn attribute for dbh');
ok(!$drh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for drh');
ok(!$drh->{ChopBlanks},         '... checking ChopBlanks attribute for drh');
ok(!$drh->{LongTruncOk},        '... checking LongTrunkOk attribute for drh');
ok(!$drh->{TaintIn},            '... checking TaintIn attribute for drh');
ok(!$drh->{TaintOut},           '... checking TaintOut attribute for drh');
ok(!$drh->{Taint},              '... checking Taint attribute for drh');
SKIP: {
    skip "Executed attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
     
    ok($drh->{Executed}, '... checking Executed attribute for drh') # due to the do() above
}
SKIP: {
    skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if ($DBI::PurePerl or $dbh->{mx_handle_list});
    cmp_ok($drh->{Kids},       '==', 1, '... checking Kids attribute for drh');
    cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for drh');
}
is($drh->{CachedKids}, undef,    '... checking CachedKids attribute for drh');
ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
ok(!defined $drh->{Profile},     '... checking Profile attribute for drh');
ok(!defined $drh->{ReadOnly},    '... checking ReadOnly attribute for drh');
cmp_ok($drh->{TraceLevel},  '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for drh');
cmp_ok($drh->{LongReadLen}, '==', 80,                    '... checking LongReadLen attribute for drh');
is($drh->{FetchHashKeyName}, 'NAME',     '... checking FetchHashKeyName attribute for drh');
is($drh->{Name},             'ExampleP', '... checking Name attribute for drh')
    unless $using_autoproxy && ok(1);
## ----------------------------------------------------------------------------
# Test the statement handle attributes.
# Create a statement handle.
my $sth = $dbh->prepare("select ctime, name from ?");
isa_ok($sth, "DBI::st");
ok(!$sth->{Executed}, '... checking Executed attribute for sth');
ok(!$dbh->{Executed}, '... checking Executed attribute for dbh');
cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth');
# Trigger an exception.
eval { 
    $sth->execute("foo") 
};
# we don't check actual opendir error msg because of locale differences
like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '... checking exception');
# Test all of the statement handle attributes.
like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
is($sth->state, 'S1000', '... checking $sth->state');
ok($sth->{Executed}, '... checking Executed attribute for sth');     # even though it failed
ok($dbh->{Executed}, '... checking Exceuted attribute for dbh');     # due to $sth->prepare, even though it failed
cmp_ok($sth->{ErrCount}, '==', 1, '... checking ErrCount attribute for sth');
$sth->{ErrCount} = 0;
cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after reset)');
# booleans
ok( $sth->{Warn},               '... checking Warn attribute for sth');
ok(!$sth->{Active},             '... checking Active attribute for sth');
ok(!$sth->{CompatMode},         '... checking CompatMode attribute for sth');
ok(!$sth->{InactiveDestroy},    '... checking InactiveDestroy attribute for sth');
ok(!$sth->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for sth');
ok(!$sth->{PrintError},         '... checking PrintError attribute for sth');
ok( $sth->{PrintWarn},          '... checking PrintWarn attribute for sth');
ok( $sth->{RaiseError},         '... checking RaiseError attribute for sth');
ok(!$dbh->{RaiseWarn},          '... checking RaiseWarn attribute for dbh');
ok(!$sth->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for sth');
ok(!$sth->{ChopBlanks},         '... checking ChopBlanks attribute for sth');
ok(!$sth->{LongTruncOk},        '... checking LongTrunkOk attribute for sth');
ok(!$sth->{TaintIn},            '... checking TaintIn attribute for sth');
ok(!$sth->{TaintOut},           '... checking TaintOut attribute for sth');
ok(!$sth->{Taint},              '... checking Taint attribute for sth');
# common attr
SKIP: {
    skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
    cmp_ok($sth->{Kids},       '==', 0, '... checking Kids attribute for sth');
    cmp_ok($sth->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for sth');
}
ok(!defined $sth->{CachedKids},  '... checking CachedKids attribute for sth');
ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth');
ok(!defined $sth->{Profile},     '... checking Profile attribute for sth');
ok(!defined $sth->{ReadOnly},    '... checking ReadOnly attribute for sth');
cmp_ok($sth->{TraceLevel},  '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for sth');
cmp_ok($sth->{LongReadLen}, '==', 80,                    '... checking LongReadLen attribute for sth');
is($sth->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for sth');
# sth specific attr
ok(!defined $sth->{CursorName}, '... checking CursorName attribute for sth');
cmp_ok($sth->{NUM_OF_FIELDS}, '==', 2, '... checking NUM_OF_FIELDS attribute for sth');
cmp_ok($sth->{NUM_OF_PARAMS}, '==', 1, '... checking NUM_OF_PARAMS attribute for sth');
my $name = $sth->{NAME};
is(ref($name), 'ARRAY', '... checking type of NAME attribute for sth');
cmp_ok(scalar(@{$name}), '==', 2, '... checking number of elements returned');
is_deeply($name, ['ctime', 'name' ], '... checking values returned');
my $name_lc = $sth->{NAME_lc};
is(ref($name_lc), 'ARRAY', '... checking type of NAME_lc attribute for sth');
cmp_ok(scalar(@{$name_lc}), '==', 2, '... checking number of elements returned');
is_deeply($name_lc, ['ctime', 'name' ], '... checking values returned');
my $name_uc = $sth->{NAME_uc};
is(ref($name_uc), 'ARRAY', '... checking type of NAME_uc attribute for sth');
cmp_ok(scalar(@{$name_uc}), '==', 2, '... checking number of elements returned');
is_deeply($name_uc, ['CTIME', 'NAME' ], '... checking values returned');
my $nhash = $sth->{NAME_hash};
is(ref($nhash), 'HASH', '... checking type of NAME_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash->{ctime},         '==', 0, '... checking values returned');
cmp_ok($nhash->{name},          '==', 1, '... checking values returned');
my $nhash_lc = $sth->{NAME_lc_hash};
is(ref($nhash_lc), 'HASH', '... checking type of NAME_lc_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash_lc})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash_lc->{ctime},         '==', 0, '... checking values returned');
cmp_ok($nhash_lc->{name},          '==', 1, '... checking values returned');
my $nhash_uc = $sth->{NAME_uc_hash};
is(ref($nhash_uc), 'HASH', '... checking type of NAME_uc_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash_uc})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash_uc->{CTIME},         '==', 0, '... checking values returned');
cmp_ok($nhash_uc->{NAME},          '==', 1, '... checking values returned');
if (
  ! $using_autoproxy
    and
  # Older Storable does not work properly with tied handles
  # Instead of hard-depending on newer Storable, just skip this
  # particular test outright
  eval { Storable->VERSION("2.16") }
) {
    # set ability to set sth attributes that are usually set internally
    for $a (qw(NAME NAME_lc NAME_uc NAME_hash NAME_lc_hash NAME_uc_hash)) {
        my $v = $sth->{$a};
        ok(eval { $sth->{$a} = dclone($sth->{$a}) }, "Can set sth $a");
        is_deeply($sth->{$a}, $v, "Can get set sth $a");
    }
}
my $type = $sth->{TYPE};
is(ref($type), 'ARRAY', '... checking type of TYPE attribute for sth');
cmp_ok(scalar(@{$type}), '==', 2, '... checking number of elements returned');
is_deeply($type, [ 4, 12 ], '... checking values returned');
my $null = $sth->{NULLABLE};
is(ref($null), 'ARRAY', '... checking type of NULLABLE attribute for sth');
cmp_ok(scalar(@{$null}), '==', 2, '... checking number of elements returned');
is_deeply($null, [ 0, 0 ], '... checking values returned');
# Should these work? They don't.
my $prec = $sth->{PRECISION};
is(ref($prec), 'ARRAY', '... checking type of PRECISION attribute for sth');
cmp_ok(scalar(@{$prec}), '==', 2, '... checking number of elements returned');
is_deeply($prec, [ 10, 1024 ], '... checking values returned');
     
my $scale = $sth->{SCALE};
is(ref($scale), 'ARRAY', '... checking type of SCALE attribute for sth');
cmp_ok(scalar(@{$scale}), '==', 2, '... checking number of elements returned');
is_deeply($scale, [ 0, 0 ], '... checking values returned');
my $params = $sth->{ParamValues};
is(ref($params), 'HASH', '... checking type of ParamValues attribute for sth');
is($params->{1}, 'foo', '... checking values returned');
is($sth->{Statement}, "select ctime, name from ?", '... checking Statement attribute for sth');
ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute for sth');
is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth attribute value';
# $h->{TraceLevel} tests are in t/09trace.t
note "Checking inheritance\n";
SKIP: {
    skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if $ENV{DBI_AUTOPROXY};
sub check_inherited {
    my ($drh, $attr, $value, $skip_sth) = @_;
    local $drh->{$attr} = $value;
    local $drh->{PrintError} = 1;
    my $dbh = $drh->connect("dummy");
    is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from drh";
    unless ($skip_sth) {
        my $sth = $dbh->prepare("select name from .");
        is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited from dbh";
    }
}
check_inherited($drh, "ReadOnly", 1, 0);
}
done_testing();
1;
# end