Author: stvn
Date: Fri May 14 18:02:44 2004
New Revision: 344
Modified:
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/03handle.t
dbi/trunk/t/04mods.t
dbi/trunk/t/05thrclone.t
dbi/trunk/t/06attrs.t
dbi/trunk/t/08keeperr.t
dbi/trunk/t/09trace.t
dbi/trunk/t/10examp.t
Log:
commiting several changes to tests
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Fri May 14 18:02:44 2004
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 48;
+use Test::More tests => 51;
## ----------------------------------------------------------------------------
## 02dbidrv.t - ...
@@ -118,8 +118,7 @@
my ($dbh, $attr) = @_;
my @ds = $dbh->SUPER::data_sources($attr);
- Test::More::ok(
- Test::More::eq_array(
+ Test::More::is_deeply((
[EMAIL PROTECTED],
[ 'dbi:Test:foo', 'dbi:Test:bar' ]
),
@@ -147,12 +146,18 @@
cmp_ok(DBI::_get_imp_data($drh), '==', 77, '... checking the DBI::_get_imp_data
function');
my @ds1 = DBI->data_sources("Test");
-ok(eq_array(
+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 {
@@ -160,9 +165,15 @@
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();
- ok(eq_array(
+ is_deeply((
[ @ds2 ],
[ 'dbi:Test:foo', 'dbi:Test:bar', 'dbi:Test:baz' ]
), '... got correct datasources from $dbh->data_sources()'
@@ -178,6 +189,12 @@
};
+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');
+}
+
# copied up to drh from dbh when dbh was DESTROYd
cmp_ok($drh->err, '==', 42, '... $dbh->DESTROY should set $drh->err to 42');
Modified: dbi/trunk/t/03handle.t
==============================================================================
--- dbi/trunk/t/03handle.t (original)
+++ dbi/trunk/t/03handle.t Fri May 14 18:02:44 2004
@@ -7,7 +7,9 @@
## ----------------------------------------------------------------------------
## 03handle.t - tests handles
## ----------------------------------------------------------------------------
-#
+# This set of tests exercises the different handles; Driver, Database and
+# Statement in various ways, in particular in their interactions with one
+# another
## ----------------------------------------------------------------------------
BEGIN {
@@ -72,52 +74,52 @@
ok(!$sth1->{Active}, '... our first statment is no longer Active since we
re-prepared it');
- $sth2 = $dbh->prepare_cached($sql, { foo => 1 });
- isa_ok($sth2, 'DBI::st');
+ my $sth3 = $dbh->prepare_cached($sql, { foo => 1 });
+ isa_ok($sth3, 'DBI::st');
- isnt($sth1, $sth2, '... prepare_cached returned a different statement handle
now');
+ isnt($sth1, $sth3, '... prepare_cached returned a different statement handle
now');
cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
ok(eq_set(
[ values %{$ck} ],
- [ $sth1, $sth2 ]
+ [ $sth1, $sth3 ]
),
'... both statment handles should be in the CachedKids');
ok($sth1->execute("."), '... executing first statement handle again');
ok($sth1->{Active}, '... first statement handle is now active again');
- my $sth3 = $dbh->prepare_cached($sql, undef, 3);
- isa_ok($sth3, 'DBI::st');
+ my $sth4 = $dbh->prepare_cached($sql, undef, 3);
+ isa_ok($sth4, 'DBI::st');
- isnt($sth1, $sth3, '... our new statement handle is not the same as our first');
+ isnt($sth1, $sth4, '... our fourth statement handle is not the same as our
first');
ok($sth1->{Active}, '... first statement handle is still active');
cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
ok(eq_set(
[ values %{$ck} ],
- [ $sth2, $sth3 ]
+ [ $sth2, $sth4 ]
),
- '... second and third statment handles should be in the CachedKids');
+ '... second and fourth statment handles should be in the CachedKids');
$sth1->finish;
ok(!$sth1->{Active}, '... first statement handle is no longer active');
- ok($sth3->execute("."), '... third statement handle executed properly');
- ok($sth3->{Active}, '... third statement handle is Active');
+ ok($sth4->execute("."), '... fourth statement handle executed properly');
+ ok($sth4->{Active}, '... fourth statement handle is Active');
- my $sth4 = $dbh->prepare_cached($sql, undef, 1);
- isa_ok($sth4, 'DBI::st');
+ my $sth5 = $dbh->prepare_cached($sql, undef, 1);
+ isa_ok($sth5, 'DBI::st');
- is($sth4, $sth3, '... third statement handle and fourth one match');
- ok(!$sth3->{Active}, '... third statement handle is not Active');
- ok(!$sth4->{Active}, '... fourth statement handle is not Active (shouldnt be its
the same as third)');
+ is($sth4, $sth5, '... fourth statement handle and fifth one match');
+ ok(!$sth4->{Active}, '... fourth statement handle is not Active');
+ ok(!$sth5->{Active}, '... fifth statement handle is not Active (shouldnt be its
the same as fifth)');
cmp_ok(scalar(keys(%{$ck})), '==', 2, '... there are two CachedKids');
ok(eq_set(
[ values %{$ck} ],
- [ $sth2, $sth4 ]
+ [ $sth2, $sth5 ]
),
- '... second and third/fourth statment handles should be in the CachedKids');
+ '... second and fourth/fifth statment handles should be in the CachedKids');
cmp_ok($warn, '==', 1, '... we still only got one warning');
$dbh->disconnect;
Modified: dbi/trunk/t/04mods.t
==============================================================================
--- dbi/trunk/t/04mods.t (original)
+++ dbi/trunk/t/04mods.t Fri May 14 18:02:44 2004
@@ -2,17 +2,57 @@
use strict;
-use Test::More tests => 6;
+use Test::More tests => 12;
+
+## ----------------------------------------------------------------------------
+## 04mods.t - ...
+## ----------------------------------------------------------------------------
+# Note:
+# the modules tested here are all marked as new and not guaranteed, so this if
+# they change, these will fail.
+## ----------------------------------------------------------------------------
BEGIN {
use_ok( 'DBI' );
- use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) );
+
+ # load these first, since the other two load them
+ # and we want to catch the error first
+ use_ok( 'DBI::Const::GetInfo::ANSI' );
+ use_ok( 'DBI::Const::GetInfo::ODBC' );
+
+ use_ok( 'DBI::Const::GetInfoType', qw(%GetInfoType) );
use_ok( 'DBI::Const::GetInfoReturn', qw(%GetInfoReturnTypes
%GetInfoReturnValues) );
}
-ok(keys %GetInfoType);
+## test GetInfoType
+
+cmp_ok(scalar(keys(%GetInfoType)), '>', 1, '... we have at least one key in the
GetInfoType hash');
+
+is_deeply(
+ \%GetInfoType,
+ { %DBI::Const::GetInfo::ANSI::InfoTypes, %DBI::Const::GetInfo::ODBC::InfoTypes },
+ '... the GetInfoType hash is constructed from the ANSI and ODBC hashes'
+ );
+
+## test GetInfoReturnTypes
+
+cmp_ok(scalar(keys(%GetInfoReturnTypes)), '>', 1, '... we have at least one key in
the GetInfoReturnType hash');
+
+is_deeply(
+ \%GetInfoReturnTypes,
+ { %DBI::Const::GetInfo::ANSI::ReturnTypes,
%DBI::Const::GetInfo::ODBC::ReturnTypes },
+ '... the GetInfoReturnType hash is constructed from the ANSI and ODBC hashes'
+ );
+
+## test GetInfoReturnValues
+
+cmp_ok(scalar(keys(%GetInfoReturnValues)), '>', 1, '... we have at least one key in
the GetInfoReturnValues hash');
+
+# ... testing GetInfoReturnValues any further would be difficult
+
+## test the two methods found in DBI::Const::GetInfoReturn
-ok(keys %GetInfoReturnTypes);
-ok(keys %GetInfoReturnValues);
+can_ok('DBI::Const::GetInfoReturn', 'Format');
+can_ok('DBI::Const::GetInfoReturn', 'Explain');
1;
Modified: dbi/trunk/t/05thrclone.t
==============================================================================
--- dbi/trunk/t/05thrclone.t (original)
+++ dbi/trunk/t/05thrclone.t Fri May 14 18:02:44 2004
@@ -12,7 +12,7 @@
plan skip_all => "this $^O perl $] not configured to support iThreads";
}
else {
- plan tests => 11;
+ plan tests => 12;
}
}
@@ -28,31 +28,40 @@
}
$DBI::neat_maxlen = 12345;
+cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was
successful');
my @connect_args = ("dbi:ExampleP:", '', '');
my $dbh_parent = DBI->connect_cached(@connect_args);
isa_ok( $dbh_parent, 'DBI::db' );
-sub tests1 {
- is($DBI::neat_maxlen, 12345);
+# this our function for the threads to run
- my $dbh = DBI->connect_cached(@connect_args);
- isa_ok( $dbh, 'DBI::db' );
- isnt($dbh, $dbh_parent);
- is($dbh->{Driver}->{Kids}, 1) unless $DBI::PurePerl && ok(1);
+sub testing {
+ cmp_ok($DBI::neat_maxlen, '==', 12345, '... DBI::neat_maxlen still holding its
value');
+
+ my $dbh = DBI->connect_cached(@connect_args);
+ isa_ok( $dbh, 'DBI::db' );
+ isnt($dbh, $dbh_parent, '... new $dbh is not the same instance as $dbh_parent');
+
+ SKIP: {
+ skip "Kids attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
+
+ cmp_ok($dbh->{Driver}->{Kids}, '==', 1, '... the Driver has one Kid');
+ }
}
+# load up the threads
+
my @thr;
-foreach (1..2) {
- print "\n\n*** creating thread $_\n";
- push @thr, threads_sub->create( \&tests1 );
-}
-foreach (@thr) {
- print "\n\n*** joining thread $_\n";
- $_->join;
+push @thr, threads_sub->create( \&testing ) foreach (1..2);
+
+# join all the threads
+
+foreach my $thread (@thr) {
+ $thread->join;
}
-ok(1);
+pass('... all tests have passed');
1;
Modified: dbi/trunk/t/06attrs.t
==============================================================================
--- dbi/trunk/t/06attrs.t (original)
+++ dbi/trunk/t/06attrs.t Fri May 14 18:02:44 2004
@@ -2,7 +2,14 @@
use strict;
-use Test::More tests => 144;
+use Test::More tests => 137;
+
+## ----------------------------------------------------------------------------
+## 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' )
@@ -22,190 +29,244 @@
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
-# ------ Check the database handle attributes.
+## ----------------------------------------------------------------------------
+# Check the database handle attributes.
# bit flag attr
-ok( $dbh->{Warn} );
-ok( $dbh->{Active} );
-ok( $dbh->{AutoCommit} );
-ok(!$dbh->{CompatMode} );
-ok(!$dbh->{InactiveDestroy} );
-ok(!$dbh->{PrintError} );
-ok( $dbh->{PrintWarn} ); # true because of perl -w above
-ok( $dbh->{RaiseError} );
-ok(!$dbh->{ShowErrorStatement} );
-ok(!$dbh->{ChopBlanks} );
-ok(!$dbh->{LongTruncOk} );
-ok(!$dbh->{TaintIn} );
-ok(!$dbh->{TaintOut} );
-ok(!$dbh->{Taint} );
-ok(!$dbh->{Executed} );
+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 InactiveDestory 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->{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
-is( $dbh->{ErrCount}, 0 );
-is( $dbh->{Kids}, 0 ) unless $DBI::PurePerl && ok(1);
-is( $dbh->{ActiveKids}, 0 ) unless $DBI::PurePerl && ok(1);
-ok( ! defined $dbh->{CachedKids} );
-ok( ! defined $dbh->{HandleError} );
-is( $dbh->{TraceLevel}, $DBI::dbi_debug & 0xF);
-is( $dbh->{FetchHashKeyName}, 'NAME', );
-is( $dbh->{LongReadLen}, 80 );
-ok( ! defined $dbh->{Profile} );
-is( $dbh->{Name}, 'dummy' ); # fails for Multiplex
-ok( ! defined $dbh->{Statement} );
-ok( ! defined $dbh->{RowCacheSize} );
+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');;
+}
+
+ok(!defined $dbh->{CachedKids}, '... 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');
+
+is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for
dbh');
+is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh'); #
fails for Multiplex
+
+cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel
attribute for dbh');
+cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking LongReadLen
attribute for dbh');
# Raise an error.
-eval { $dbh->do('select foo from foo') };
-ok( my $err = $@ );
-ok( $err =~ /^DBD::(ExampleP|Multiplex)::db do failed: Unknown field names: foo/ ) or
print "got: $err\n";
-ok( $dbh->err );
-ok( my $errstr = $dbh->errstr);
-ok( $errstr =~ /^Unknown field names: foo\b/ ) or print "got: $errstr\n";
-is( $dbh->state, 'S1000' );
-
-ok( $dbh->{Executed} ); # even though it failed
-$dbh->{Executed} = 0; # reset(able)
-ok(!$dbh->{Executed} ); # reset
-is( $dbh->{ErrCount}, 1 );
+eval {
+ $dbh->do('select foo from foo')
+};
+like($@, qr/^DBD::(ExampleP|Multiplex)::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');
-# ------ Test the driver handle attributes.
+is($dbh->state, 'S1000', '... checking $dbh->state');
-ok( my $drh = $dbh->{Driver} );
+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 );
-is( $drh->{ErrCount}, 0 );
+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 InactiveDestory 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(!$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
+}
-ok( $drh->{Warn} );
-ok( $drh->{Active} );
-ok( $drh->{AutoCommit} );
-ok(!$drh->{CompatMode} );
-ok(!$drh->{InactiveDestroy} );
-ok(!$drh->{PrintError} );
-ok( $drh->{PrintWarn} ); # true because of perl -w above
-ok(!$drh->{RaiseError} );
-ok(!$drh->{ShowErrorStatement} );
-ok(!$drh->{ChopBlanks} );
-ok(!$drh->{LongTruncOk} );
-ok(!$drh->{TaintIn} );
-ok(!$drh->{TaintOut} );
-ok(!$drh->{Taint} );
-ok( $drh->{Executed} ) unless $DBI::PurePerl && ok(1); # due to the do() above
-
-unless ($DBI::PurePerl or $dbh->{mx_handle_list}) {
-is( $drh->{Kids}, 1 );
-is( $drh->{ActiveKids}, 1 );
+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');
}
-else { ok(1); ok(1); }
-ok( ! defined $drh->{CachedKids} );
-ok( ! defined $drh->{HandleError} );
-is( $drh->{TraceLevel}, $DBI::dbi_debug & 0xF );
-is( $drh->{FetchHashKeyName}, 'NAME', );
-ok( ! defined $drh->{Profile} );
-is( $drh->{LongReadLen}, 80 );
-is( $drh->{Name}, 'ExampleP' );
-# ------ Test the statement handle attributes.
+ok(!defined $drh->{CachedKids}, '... checking CachedKids attribute for drh');
+ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
+ok(!defined $drh->{Profile}, '... checking Profile 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');
+
+## ----------------------------------------------------------------------------
+# Test the statement handle attributes.
# Create a statement handle.
-(ok my $sth = $dbh->prepare("select ctime, name from ?") );
-ok( !$sth->{Executed} );
-ok( !$dbh->{Executed} );
-is( $sth->{ErrCount}, 0 );
+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") };
-ok( $err = $@ );
+eval {
+ $sth->execute("foo")
+};
# we don't check actual opendir error msg because of locale differences
-like( $err, qr/^DBD::(ExampleP|Multiplex)::st execute failed: opendir\(foo\): /i );
+like($@, qr/^DBD::(ExampleP|Multiplex)::st execute failed: opendir\(foo\): /i, '...
checking exception');
# Test all of the statement handle attributes.
-ok( $sth->errstr =~ /^opendir\(foo\): / ) or print "errstr: ".$sth->errstr."\n";
-is( $sth->state, 'S1000' );
-ok( $sth->{Executed} ); # even though it failed
-ok( $dbh->{Executed} ); # due to $sth->prepare, even though it failed
-
-is( $sth->{ErrCount}, 1 );
-eval { $sth->{ErrCount} = 42 };
-ok($@);
-like($@, qr/STORE failed:/);
-is( $sth->{ErrCount}, 42 );
+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');
+eval {
+ $sth->{ErrCount} = 42
+};
+like($@, qr/STORE failed:/, '... checking exception');
+
+cmp_ok($sth->{ErrCount}, '==', 42 , '... checking ErrCount attribute for sth (after
assignment)');
+
$sth->{ErrCount} = 0;
-is( $sth->{ErrCount}, 0 );
+cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after
reset)');
# booleans
-ok( $sth->{Warn} );
-ok(!$sth->{Active} );
-ok(!$sth->{CompatMode} );
-ok(!$sth->{InactiveDestroy} );
-ok(!$sth->{PrintError} );
-ok( $sth->{PrintWarn} );
-ok( $sth->{RaiseError} );
-ok(!$sth->{ShowErrorStatement} );
-ok(!$sth->{ChopBlanks} );
-ok(!$sth->{LongTruncOk} );
-ok(!$sth->{TaintIn} );
-ok(!$sth->{TaintOut} );
-ok(!$sth->{Taint} );
+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->{PrintError}, '... checking PrintError attribute for sth');
+ok( $sth->{PrintWarn}, '... checking PrintWarn attribute for sth');
+ok( $sth->{RaiseError}, '... checking RaiseError attribute for sth');
+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
-is( $sth->{Kids}, 0 ) unless $DBI::PurePerl && ok(1);
-is( $sth->{ActiveKids}, 0 ) unless $DBI::PurePerl && ok(1);
-ok( ! defined $sth->{CachedKids} );
-ok( ! defined $sth->{HandleError} );
-is( $sth->{TraceLevel}, $DBI::dbi_debug & 0xF);
-is( $sth->{FetchHashKeyName}, 'NAME', );
-ok( ! defined $sth->{Profile} );
-is( $sth->{LongReadLen}, 80 );
-ok( ! defined $sth->{Profile} );
+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');
+
+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} );
+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');
-is( $sth->{NUM_OF_FIELDS}, 2 );
-is( $sth->{NUM_OF_PARAMS}, 1 );
-ok( my $name = $sth->{NAME} );
-is( @$name, 2 );
-ok( $name->[0] eq 'ctime' );
-ok( $name->[1] eq 'name' );
-ok( my $name_lc = $sth->{NAME_lc} );
-ok( $name_lc->[0] eq 'ctime' );
-ok( $name_lc->[1] eq 'name' );
-ok( my $name_uc = $sth->{NAME_uc} );
-ok( $name_uc->[0] eq 'CTIME' );
-ok( $name_uc->[1] eq 'NAME' );
-ok( my $nhash = $sth->{NAME_hash} );
-is( keys %$nhash, 2 );
-is( $nhash->{ctime}, 0 );
-is( $nhash->{name}, 1 );
-ok( my $nhash_lc = $sth->{NAME_lc_hash} );
-is( $nhash_lc->{ctime}, 0 );
-is( $nhash_lc->{name}, 1 );
-ok( my $nhash_uc = $sth->{NAME_uc_hash} );
-is( $nhash_uc->{CTIME}, 0 );
-is( $nhash_uc->{NAME}, 1 );
-ok( my $type = $sth->{TYPE} );
-is( @$type, 2 );
-is( $type->[0], 4 );
-is( $type->[1], 12 );
-ok( my $null = $sth->{NULLABLE} );
-is( @$null, 2 );
-is( $null->[0], 0 );
-is( $null->[1], 0 );
+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_lc), 'HASH', '... checking type of NAME_us_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');
+
+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.
-ok( my $prec = $sth->{PRECISION} );
-is( $prec->[0], 10 );
-is( $prec->[1], 1024 );
-ok( my $scale = $sth->{SCALE} );
-is( $scale->[0], 0 );
-is( $scale->[1], 0 );
-
-ok( my $params = $sth->{ParamValues} );
-is( $params->{1}, 'foo' );
-is( $sth->{Statement}, "select ctime, name from ?" );
-ok( ! defined $sth->{RowsInCache} );
+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');
# $h->{TraceLevel} tests are in t/09trace.t
Modified: dbi/trunk/t/08keeperr.t
==============================================================================
--- dbi/trunk/t/08keeperr.t (original)
+++ dbi/trunk/t/08keeperr.t Fri May 14 18:02:44 2004
@@ -2,29 +2,49 @@
use strict;
-use Test::More tests => 63;
+use Test::More tests => 69;
+
+## ----------------------------------------------------------------------------
+## 08keeperr.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok('DBI');
+}
$|=1;
$^W=1;
-
+
+## ----------------------------------------------------------------------------
+# subclass DBI
+
+# DBI subclass
package My::DBI;
use base 'DBI';
+# Database handle subclass
package My::DBI::db;
use base 'DBI::db';
+# Statement handle subclass
package My::DBI::st;
use base 'DBI::st';
sub execute {
- my $sth = shift;
- # we localize and attribute here to check that the correpoding STORE
- # at scope exit doesn't clear any recorded error
- local $sth->{CompatMode} = 0;
- my $rv = $sth->SUPER::execute(@_);
- return $rv;
+ my $sth = shift;
+ # we localize and attribute here to check that the correpoding STORE
+ # at scope exit doesn't clear any recorded error
+ local $sth->{CompatMode} = 0;
+ my $rv = $sth->SUPER::execute(@_);
+ return $rv;
}
+
+## ----------------------------------------------------------------------------
+# subclass the subclass of DBI
+
package Test;
use strict;
@@ -32,7 +52,7 @@
use DBI;
-my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError=>0, RaiseError=>1 });
+my @con_info = ('dbi:ExampleP:.', undef, undef, { PrintError => 0, RaiseError => 1 });
sub test_select {
my $dbh = shift;
@@ -42,141 +62,204 @@
}
my $err1 = test_select( My::DBI->connect(@con_info) );
-::ok($err1 =~ /^DBD::(ExampleP|Multiplex)::db selectrow_arrayref failed: opendir/) or
print "got: $err1\n";
+Test::More::like($err1, qr/^DBD::(ExampleP|Multiplex)::db selectrow_arrayref failed:
opendir/, '... checking error');
my $err2 = test_select( DBI->connect(@con_info) );
-::ok($err2 =~ /^DBD::(ExampleP|Multiplex)::db selectrow_arrayref failed: opendir/) or
print "got: $err2\n";
+Test::More::like($err2, qr/^DBD::(ExampleP|Multiplex)::db selectrow_arrayref failed:
opendir/, '... checking error');
package main;
-print "test HandleSetErr\n";
+## ----------------------------------------------------------------------------
+# test HandleSetErr
my $dbh = DBI->connect(@con_info);
+isa_ok($dbh, "DBI::db");
+
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 1;
-$dbh->{PrintWarn} = 1;
+$dbh->{PrintWarn} = 1;
+# warning handler
my %warn = ( failed => 0, warning => 0 );
my @handlewarn = (0,0,0);
$SIG{__WARN__} = sub {
my $msg = shift;
if ($msg =~ /^DBD::ExampleP::\S+\s+(\S+)\s+(\w+)/) {
- ++$warn{$2};
- $msg =~ s/\n/\\n/g;
- print "warn: '$msg'\n";
- return;
+ ++$warn{$2};
+ $msg =~ s/\n/\\n/g;
+ print "warn: '$msg'\n";
+ return;
}
warn $msg;
};
-#$dbh->trace(2);
+
+# HandleSetErr handler
$dbh->{HandleSetErr} = sub {
my ($h, $err, $errstr, $state) = @_;
- return 0 unless defined $err;
+ return 0
+ unless defined $err;
++$handlewarn[ $err ? 2 : length($err) ]; # count [info, warn, err] calls
- return 1
- if $state && $state eq "return"; # for tests
+ return 1
+ if $state && $state eq "return"; # for tests
($_[1], $_[2], $_[3]) = (99, "errstr99", "OV123")
- if $state && $state eq "override"; # for tests
- return 0 if $err; # be transparent for errors
+ if $state && $state eq "override"; # for tests
+ return 0
+ if $err; # be transparent for errors
local $^W;
print "HandleSetErr called: h=$h, err=$err, errstr=$errstr, state=$state\n";
return 0;
};
-ok(!defined $DBI::err);
+
+# start our tests
+
+ok(!defined $DBI::err, '... $DBI::err is not defined');
+
+# ----
$dbh->set_err("", "(got info)");
-is(defined $DBI::err, 1); # true
-is($DBI::err, "");
-is($DBI::errstr, "(got info)");
-is($dbh->errstr, "(got info)");
-is($warn{failed}, 0);
-is($warn{warning}, 0);
-is("@handlewarn", "1 0 0");
+
+ok(defined $DBI::err, '... $DBI::err is defined'); # true
+is($DBI::err, "", '... $DBI::err is an empty string');
+is($DBI::errstr, "(got info)", '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)", '... $dbh->errstr matches $DBI::errstr');
+cmp_ok($warn{failed}, '==', 0, '... $warn{failed} is 0');
+cmp_ok($warn{warning}, '==', 0, '... $warn{warning} is 0');
+is_deeply([EMAIL PROTECTED], [ 1, 0, 0 ], '... the @handlewarn array is (1, 0, 0)');
+
+# ----
$dbh->set_err(0, "(got warn)", "AA001"); # triggers PrintWarn
-ok(defined $DBI::err);
-is($DBI::err, "0");
-is($DBI::errstr, "(got info)\n(got warn)");
-is($dbh->errstr, "(got info)\n(got warn)");
-is($warn{warning}, 1);
-is("@handlewarn", "1 1 0");
-is($DBI::state, "AA001");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+is($DBI::err, "0", '... $DBI::err is "0"');
+is($DBI::errstr, "(got info)\n(got warn)",
+ '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)\n(got warn)",
+ '... $dbh->errstr matches $DBI::errstr');
+is($DBI::state, "AA001", '... $DBI::state is AA001');
+cmp_ok($warn{warning}, '==', 1, '... $warn{warning} is 1');
+is_deeply([EMAIL PROTECTED], [ 1, 1, 0 ], '... the @handlewarn array is (1, 1, 0)');
+
+
+# ----
$dbh->set_err("", "(got more info)"); # triggers PrintWarn
-ok(defined $DBI::err);
-is($DBI::err, "0"); # not "", ie it's still a warn
-is($dbh->err, "0");
-is($DBI::errstr, "(got info)\n(got warn)\n(got more info)");
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info)");
-is($warn{warning}, 2);
-is("@handlewarn", "2 1 0");
-is($DBI::state, "AA001");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+is($DBI::err, "0", '... $DBI::err is "0"'); # not "", ie it's
still a warn
+is($dbh->err, "0", '... $dbh->err is "0"');
+is($DBI::state, "AA001", '... $DBI::state is AA001');
+is($DBI::errstr, "(got info)\n(got warn)\n(got more info)",
+ '... $DBI::errstr is as we expected');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info)",
+ '... $dbh->errstr matches $DBI::errstr');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is_deeply([EMAIL PROTECTED], [ 2, 1, 0 ], '... the @handlewarn array is (2, 1, 0)');
+
+
+# ----
$dbh->{RaiseError} = 0;
$dbh->{PrintError} = 1;
+# ----
+
$dbh->set_err("42", "(got error)", "AA002");
-is($DBI::err, 42);
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)");
-#is($warn{failed}, 1);
-is($warn{warning}, 2);
-is("@handlewarn", "2 1 1");
-is($DBI::state, "AA002");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)",
+ '... $dbh->errstr is as we expected');
+is($DBI::state, "AA002", '... $DBI::state is AA002');
+is_deeply([EMAIL PROTECTED], [ 2, 1, 1 ], '... the @handlewarn array is (2, 1, 1)');
+
+# ----
$dbh->set_err("", "(got info)");
-is($DBI::err, 42);
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)");
-is($warn{warning}, 2);
-is("@handlewarn", "3 1 1");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)",
+ '... $dbh->errstr is as we expected');
+is_deeply([EMAIL PROTECTED], [ 3, 1, 1 ], '... the @handlewarn array is (3, 1, 1)');
+
+# ----
$dbh->set_err("0", "(got warn)"); # no PrintWarn because it's already an err
-is($DBI::err, 42);
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn)");
-is($warn{warning}, 2);
-is("@handlewarn", "3 2 1");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 42, '... $DBI::err is 42');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn)",
+ '... $dbh->errstr is as we expected');
+is_deeply([EMAIL PROTECTED], [ 3, 2, 1 ], '... the @handlewarn array is (3, 2, 1)');
+
+# ----
$dbh->set_err("4200", "(got new error)", "AA003");
-is($DBI::err, 4200);
-is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now
AA003]\n(got new error)");
-is($warn{warning}, 2);
-is("@handlewarn", "3 2 2");
+
+ok(defined $DBI::err, '... $DBI::err is defined');
+cmp_ok($DBI::err, '==', 4200, '... $DBI::err is 4200');
+cmp_ok($warn{warning}, '==', 2, '... $warn{warning} is 2');
+is($dbh->errstr, "(got info)\n(got warn)\n(got more info) [state was AA001 now
AA002]\n(got error)\n(got info)\n(got warn) [err was 42 now 4200] [state was AA002 now
AA003]\n(got new error)",
+ '... $dbh->errstr is as we expected');
+is_deeply([EMAIL PROTECTED], [ 3, 2, 2 ], '... the @handlewarn array is (3, 2, 2)');
+
+# ----
$dbh->set_err(undef, "foo", "bar"); # clear error
-ok(!defined $dbh->errstr);
-ok(!defined $dbh->err);
-is($dbh->state, "");
+ok(!defined $dbh->errstr, '... $dbh->errstr is defined');
+ok(!defined $dbh->err, '... $dbh->err is defined');
+is($dbh->state, "", '... $dbh->state is an empty string');
+
+# ----
%warn = ( failed => 0, warning => 0 );
@handlewarn = (0,0,0);
+
+# ----
+
my @ret;
@ret = $dbh->set_err(1, "foo"); # PrintError
-is(scalar @ret, 1);
-ok(!defined $ret[0]);
-ok(!defined $dbh->set_err(2, "bar")); # PrintError
-ok(!defined $dbh->set_err(3, "baz")); # PrintError
-ok(!defined $dbh->set_err(0, "warn")); # PrintError
-is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn");
-is($warn{failed}, 4);
-is("@handlewarn", "0 1 3");
+
+cmp_ok(scalar(@ret), '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+ok(!defined $dbh->set_err(2, "bar"), '... $dbh->set_err returned undefiend'); #
PrintError
+ok(!defined $dbh->set_err(3, "baz"), '... $dbh->set_err returned undefiend'); #
PrintError
+ok(!defined $dbh->set_err(0, "warn"), '... $dbh->set_err returned undefiend'); #
PrintError
+is($dbh->errstr, "foo [err was 1 now 2]\nbar [err was 2 now 3]\nbaz\nwarn",
+ '... $dbh->errstr is as we expected');
+is($warn{failed}, 4, '... $warn{failed} is 4');
+is_deeply([EMAIL PROTECTED], [ 0, 1, 3 ], '... the @handlewarn array is (0, 1, 3)');
+
+# ----
$dbh->set_err(undef, undef, undef); # clear error
+
@ret = $dbh->set_err(1, "foo", "AA123", "method");
-is(scalar @ret, 1);
-ok(!defined $ret[0]);
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+
@ret = $dbh->set_err(1, "foo", "AA123", "method", "42");
-is(scalar @ret, 1);
-is($ret[0], "42");
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+is($ret[0], "42", '... the first value is "42"');
+
@ret = $dbh->set_err(1, "foo", "return");
-is(scalar @ret, 0);
+cmp_ok(scalar @ret, '==', 0, '... returned no values');
+
+# ----
$dbh->set_err(undef, undef, undef); # clear error
+
@ret = $dbh->set_err("", "info", "override");
-is(scalar @ret, 1);
-ok(!defined $ret[0]);
-is($dbh->err, 99);
-is($dbh->errstr, "errstr99");
-is($dbh->state, "OV123");
+cmp_ok(scalar @ret, '==', 1, '... only returned one value');
+ok(!defined $ret[0], '... the first value is undefined');
+cmp_ok($dbh->err, '==', 99, '... $dbh->err is 99');
+is($dbh->errstr, "errstr99", '... $dbh->errstr is as we expected');
+is($dbh->state, "OV123", '... $dbh->state is as we expected');
1;
# end
Modified: dbi/trunk/t/09trace.t
==============================================================================
--- dbi/trunk/t/09trace.t (original)
+++ dbi/trunk/t/09trace.t Fri May 14 18:02:44 2004
@@ -2,13 +2,25 @@
# vim:sw=4:ts=8
use strict;
+
+# 66 tests originally
use Test::More tests => 66;
-BEGIN { use_ok( 'DBI' ); }
+## ----------------------------------------------------------------------------
+## 09trace.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok( 'DBI' );
+}
$|=1;
+## ----------------------------------------------------------------------------
# Connect to the example driver.
+
my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
{ PrintError => 0,
RaiseError => 1,
@@ -19,16 +31,17 @@
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
+## ----------------------------------------------------------------------------
+# Check the database handle attributes.
-# ------ Check the database handle attributes.
-
-is( $dbh->{TraceLevel}, $DBI::dbi_debug & 0xF);
+cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel
attribute');
my $trace_file = "dbitrace.log";
-print "trace to file $trace_file\n";
+
1 while unlink $trace_file;
+
$dbh->trace(0, $trace_file);
-ok( -f $trace_file );
+ok( -f $trace_file, '... trace file successfully created');
my @names = qw(
SQL
@@ -59,19 +72,20 @@
$flag{$name} = $flag1;
$all_flags |= $flag1
- if defined $flag1; # reduce noise if there's a bug
+ if defined $flag1; # reduce noise if there's a bug
}
+
print "parse_trace_flag @names\n";
-is keys %flag, @names;
+ok(eq_set([ keys %flag ], [ @names ]), '...');
$dbh->{TraceLevel} = 0;
$dbh->{TraceLevel} = join "|", @names;
-is $dbh->{TraceLevel}, $all_flags;
+is($dbh->{TraceLevel}, $all_flags, '...');
{
-print "inherit\n";
-my $sth = $dbh->prepare("select ctime, name from foo");
-isa_ok( $sth, 'DBI::st' );
-is( $sth->{TraceLevel}, $all_flags );
+ print "inherit\n";
+ my $sth = $dbh->prepare("select ctime, name from foo");
+ isa_ok( $sth, 'DBI::st' );
+ is( $sth->{TraceLevel}, $all_flags );
}
$dbh->{TraceLevel} = 0;
@@ -80,17 +94,17 @@
ok $dbh->{TraceLevel};
{
-print "unknown parse_trace_flag\n";
-my $warn = 0;
-local $SIG{__WARN__} = sub {
- if ($_[0] =~ /unknown/i) { ++$warn; print "warn: ",@_ }else{ warn @_ }
-};
-is $dbh->parse_trace_flag("nonesuch"), undef;
-is $warn, 0;
-is $dbh->parse_trace_flags("nonesuch"), 0;
-is $warn, 1;
-is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"), $dbh->parse_trace_flag("SQL");
-is $warn, 2;
+ print "unknown parse_trace_flag\n";
+ my $warn = 0;
+ local $SIG{__WARN__} = sub {
+ if ($_[0] =~ /unknown/i) { ++$warn; print "warn: ",@_ }else{ warn @_ }
+ };
+ is $dbh->parse_trace_flag("nonesuch"), undef;
+ is $warn, 0;
+ is $dbh->parse_trace_flags("nonesuch"), 0;
+ is $warn, 1;
+ is $dbh->parse_trace_flags("nonesuch|SQL|nonesuch2"),
$dbh->parse_trace_flag("SQL");
+ is $warn, 2;
}
$dbh->trace(0);
Modified: dbi/trunk/t/10examp.t
==============================================================================
--- dbi/trunk/t/10examp.t (original)
+++ dbi/trunk/t/10examp.t Fri May 14 18:02:44 2004
@@ -1,4 +1,4 @@
-#!perl -w
+#!perl -Tw
use lib qw(blib/arch blib/lib); # needed since -T ignores PERL5LIB
use DBI qw(:sql_types);
@@ -10,96 +10,141 @@
my $haveFileSpec = eval { require File::Spec };
require VMS::Filespec if $^O eq 'VMS';
-use Test::More tests => 247;
+# originally 246 tests
+use Test::More tests => 252;
+#use Test::More 'no_plan';
+
+# "globals"
+my ($r, $dbh);
## testing tracing to file
+sub trace_to_file {
-my $trace_file = "dbitrace.log";
+ my $trace_file = "dbitrace.log";
-SKIP: {
- skip "no trace file to clean up", 2 unless (-e $trace_file);
+ SKIP: {
+ skip "no trace file to clean up", 2 unless (-e $trace_file);
- is(unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
- ok( !-e $trace_file, "Trace file actually gone" );
-}
+ is(unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
+ ok( !-e $trace_file, "Trace file actually gone" );
+ }
-my $orig_trace_level = DBI->trace;
-DBI->trace(3, $trace_file); # enable trace before first driver load
+ my $orig_trace_level = DBI->trace;
+ DBI->trace(3, $trace_file); # enable trace before first driver load
+
+ $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
+ die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
-my $r;
-my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
-die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
+ isa_ok($dbh, 'DBI::db');
-ok($dbh);
-isa_ok($dbh, 'DBI::db');
+ $dbh->dump_handle("dump_handle test, write to log file", 2);
-$dbh->dump_handle("dump_handle test, write to log file", 2);
+ DBI->trace(0, undef); # turn off and restore to STDERR
+
+ SKIP: {
+ skip "cygwin has buffer flushing bug", 1 if ($^O =~ /cygwin/i);
+ ok( -s $trace_file, "trace file size = " . -s $trace_file);
+ }
-DBI->trace(0, undef); # turn off and restore to STDERR
-if ($^O =~ /cygwin/i) { # cygwin has buffer flushing bug
- ok(1);
-} else {
- ok( -s $trace_file, "trace file size = " . -s $trace_file);
+ is( unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
+ ok( !-e $trace_file, "Trace file actually gone" );
}
-is( unlink( $trace_file ), 1, "Remove trace file: $trace_file" );
-ok( !-e $trace_file, "Trace file actually gone" );
+trace_to_file();
# internal hack to assist debugging using DBI_TRACE env var. See DBI.pm.
DBI->trace(@DBI::dbi_debug) if @DBI::dbi_debug;
-$dbh->{Taint} = 1 unless $DBI::PurePerl;
-
my $dbh2;
eval {
- $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError=>1, AutoCommit=>0
});
+ $dbh2 = DBI->connect("dbi:NoneSuch:foobar", 1, 1, { RaiseError => 1, AutoCommit
=> 0 });
};
-ok($@, $@);
-ok(!$dbh2);
+like($@, qr/install_driver\(NoneSuch\) failed/, '... we should have an exception
here');
+ok(!$dbh2, '... $dbh2 should not be defined');
$dbh2 = DBI->connect('dbi:ExampleP:', '', '');
ok($dbh ne $dbh2);
-my $dbh3 = DBI->connect_cached('dbi:ExampleP:', '', '');
-my $dbh4 = DBI->connect_cached('dbi:ExampleP:', '', '');
-ok($dbh3 eq $dbh4);
-my $dbh5 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo=>1 });
-ok($dbh5 ne $dbh4);
-#$dbh->trace(2);
+sub check_connect_cached {
+ # connect_cached
+ # ------------------------------------------
+ # This test checks that connect_cached works
+ # and how it then relates to the CachedKids
+ # attribute for the driver.
+
+ my $dbh_cached_1 = DBI->connect_cached('dbi:ExampleP:', '', '');
+ my $dbh_cached_2 = DBI->connect_cached('dbi:ExampleP:', '', '');
+ my $dbh_cached_3 = DBI->connect_cached('dbi:ExampleP:', '', '', { examplep_foo
=> 1 });
+
+ isa_ok($dbh_cached_1, "DBI::db");
+ isa_ok($dbh_cached_2, "DBI::db");
+ isa_ok($dbh_cached_3, "DBI::db");
+
+ is($dbh_cached_1, $dbh_cached_2, '... these 2 handles are cached, so they are
the same');
+ isnt($dbh_cached_3, $dbh_cached_2, '... this handle was created with different
parameters, so it is not the same');
+
+ my $drh = $dbh->{Driver};
+ isa_ok($drh, "DBI::dr");
+
+ my @cached_kids = values %{$drh->{CachedKids}};
+ ok(eq_set([EMAIL PROTECTED], [ $dbh_cached_1, $dbh_cached_3 ]), '... these are
our cached kids');
+
+ $drh->{CachedKids} = {};
+ cmp_ok(scalar(keys %{$drh->{CachedKids}}), '==', 0, '... we have emptied out
cache');
+}
+
+check_connect_cached();
+
$dbh->{AutoCommit} = 1;
$dbh->{PrintError} = 0;
-ok($dbh->{Taint} == 1) unless $DBI::PurePerl && ok(1);
+
ok($dbh->{AutoCommit} == 1);
-ok($dbh->{PrintError} == 0);
-#$dbh->trace(0); die;
+cmp_ok($dbh->{PrintError}, '==', 0, '... PrintError should be 0');
-ok($dbh->{FetchHashKeyName} eq 'NAME');
-ok($dbh->{example_driver_path} =~ m:DBD/ExampleP.pm$:, $dbh->{example_driver_path});
-#$dbh->trace(2);
-
-print "quote\n";
-ok($dbh->quote("quote's") eq "'quote''s'");
-ok($dbh->quote("42", SQL_VARCHAR) eq "'42'");
-ok($dbh->quote("42", SQL_INTEGER) eq "42");
-ok($dbh->quote(undef) eq "NULL");
+SKIP: {
+ skip "cant test this if we have DBI::PurePerl", 1 if $DBI::PurePerl;
+ $dbh->{Taint} = 1;
+ ok($dbh->{Taint} == 1);
+}
+
+is($dbh->{FetchHashKeyName}, 'NAME', '... FetchHashKey is NAME');
+like($dbh->{example_driver_path}, qr/DBD\/ExampleP\.pm$/, '... checking the example
driver_path');
+
+sub check_quote {
+ # checking quote
+ is($dbh->quote("quote's"), "'quote''s'", '... quoting strings with
embedded single quotes');
+ is($dbh->quote("42", SQL_VARCHAR), "'42'", '... quoting number as
SQL_VARCHAR');
+ is($dbh->quote("42", SQL_INTEGER), "42", '... quoting number as
SQL_INTEGER');
+ is($dbh->quote(undef), "NULL", '... quoting
undef as NULL');
+}
+
+check_quote();
-print "quote_identifier\n";
my $get_info = $dbh->{examplep_get_info} || {};
-$get_info->{29} ='"'; # SQL_IDENTIFIER_QUOTE_CHAR
-$dbh->{examplep_get_info} = $get_info; # trigger STORE
-ok($dbh->quote_identifier('foo') eq '"foo"', $dbh->quote_identifier('foo'));
-ok($dbh->quote_identifier('f"o') eq '"f""o"', $dbh->quote_identifier('f"o'));
-ok($dbh->quote_identifier('foo','bar') eq '"foo"."bar"');
-ok($dbh->quote_identifier(undef,undef,'bar') eq '"bar"');
-
-$get_info->{41} ='@'; # SQL_CATALOG_NAME_SEPARATOR
-$get_info->{114} = 2; # SQL_CATALOG_LOCATION
-$dbh->{examplep_get_info} = $get_info; # trigger STORE
-ok($dbh->quote_identifier('foo',undef,'bar') eq '"foo"."bar"');
+sub check_quote_identifier {
+ # quote_identifier
+ $get_info->{29} ='"'; #
SQL_IDENTIFIER_QUOTE_CHAR
+ $dbh->{examplep_get_info} = $get_info; # trigger STORE
+
+ is($dbh->quote_identifier('foo'), '"foo"', '... properly
quotes foo as "foo"');
+ is($dbh->quote_identifier('f"o'), '"f""o"', '... properly
quotes f"o as "f""o"');
+ is($dbh->quote_identifier('foo','bar'), '"foo"."bar"', '... properly
quotes foo, bar as "foo"."bar"');
+ is($dbh->quote_identifier(undef,undef,'bar'), '"bar"', '... properly
quotes undef, undef, bar as "bar"');
+
+ is($dbh->quote_identifier('foo',undef,'bar'), '"foo"."bar"', '... properly
quotes foo, undef, bar as "foo"."bar"');
+
+ $get_info->{41} ='@'; # SQL_CATALOG_NAME_SEPARATOR
+ $get_info->{114} = 2; # SQL_CATALOG_LOCATION
+ $dbh->{examplep_get_info} = $get_info; # trigger STORE
+
+ # force cache refresh
+ $dbh->{dbi_quote_identifier_cache} = undef;
+ is($dbh->quote_identifier('foo',undef,'bar'), '"bar"@"foo"', '... now quotes
it as "bar"@"foo" after flushing cache');
+}
+
+check_quote_identifier();
-$dbh->{dbi_quote_identifier_cache} = undef; # force cache refresh
-ok($dbh->quote_identifier('foo',undef,'bar') eq '"bar"@"foo"');
print "others\n";
eval { $dbh->commit('dummy') };
@@ -565,30 +610,41 @@
#$dbh->trace(0); die;
-print "dump_results\n";
-ok($csr_a = $dbh->prepare($std_sql));
-if ($haveFileSpec && length(File::Spec->updir)) {
- ok($csr_a->execute(File::Spec->updir));
-} else {
- ok($csr_a->execute('../'));
-}
-my $dump_dir = ($ENV{TMP} || $ENV{TEMP} || $ENV{TMPDIR}
- || $ENV{'SYS$SCRATCH'} || '/tmp');
-my $dump_file = ($haveFileSpec)
- ? File::Spec->catfile($dump_dir, 'dumpcsr.tst')
- : "$dump_dir/dumpcsr.tst";
-($dump_file) = ($dump_file =~ m/^(.*)$/); # untaint
+{
+ # dump_results;
+ my $sth = $dbh->prepare($std_sql);
+
+ isa_ok($sth, "DBI::st");
+
+ if ($haveFileSpec && length(File::Spec->updir)) {
+ ok($sth->execute(File::Spec->updir));
+ } else {
+ ok($sth->execute('../'));
+ }
+
+ my $dump_dir = ($ENV{TMP} ||
+ $ENV{TEMP} ||
+ $ENV{TMPDIR} ||
+ $ENV{'SYS$SCRATCH'} ||
+ '/tmp');
+ my $dump_file = ($haveFileSpec) ?
+ File::Spec->catfile($dump_dir,
'dumpcsr.tst')
+ :
+ "$dump_dir/dumpcsr.tst";
+ ($dump_file) = ($dump_file =~ m/^(.*)$/); # untaint
+
+ SKIP: {
+ skip "# dump_results test skipped: unable to open $dump_file: $!\n", 2
unless (open(DUMP_RESULTS, ">$dump_file"));
+ ok($sth->dump_results("10", "\n", ",\t", \*DUMP_RESULTS));
+ close(DUMP_RESULTS);
+ ok(-s $dump_file > 0);
+ }
+
+ is( unlink( $dump_file ), 1, "Remove $dump_file" );
+ ok( !-e $dump_file, "Actually gone" );
-SKIP: {
- skip "# dump_results test skipped: unable to open $dump_file: $!\n", 2 unless
(open(DUMP_RESULTS, ">$dump_file"));
- ok($csr_a->dump_results("10", "\n", ",\t", \*DUMP_RESULTS));
- close(DUMP_RESULTS);
- ok(-s $dump_file > 0);
}
-is( unlink( $dump_file ), 1, "Remove $dump_file" );
-ok( !-e $dump_file, "Actually gone" );
-
print "table_info\n";
# First generate a list of all subdirectories
$dir = $haveFileSpec ? File::Spec->curdir() : ".";
