Author: stvn
Date: Mon May 10 15:11:48 2004
New Revision: 335
Modified:
dbi/trunk/t/02dbidrv.t
dbi/trunk/t/07kids.t
dbi/trunk/t/15array.t
Log:
Updating Test files for Phalanx project
Modified: dbi/trunk/t/02dbidrv.t
==============================================================================
--- dbi/trunk/t/02dbidrv.t (original)
+++ dbi/trunk/t/02dbidrv.t Mon May 10 15:11:48 2004
@@ -154,7 +154,7 @@
), '... got correct datasources from DBI->data_sources("Test")'
);
-# create scope to test DESTROY behaviour
+# create scope to test $dbh DESTROY behaviour
do {
my $dbh = $drh->connect;
Modified: dbi/trunk/t/07kids.t
==============================================================================
--- dbi/trunk/t/07kids.t (original)
+++ dbi/trunk/t/07kids.t Mon May 10 15:11:48 2004
@@ -3,14 +3,31 @@
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
+
+if ($DBI::PurePerl) {
+ plan skip_all => '$h->{Kids} attribute not supported for DBI::PurePerl';
+}
+else {
+ plan tests => 20;
+}
## ----------------------------------------------------------------------------
## 07kids.t
## ----------------------------------------------------------------------------
-# This test check the Kids and the ActiveKids attributes
-# NOTE:
-# there is likely more I can do here, I just need to figure out what
+# This test check the Kids and the ActiveKids attributes and how they act
+# in various situations.
+#
+# Check the database handle's kids:
+# - upon creation of handle
+# - upon creation of statement handle
+# - after execute of statement handle
+# - after finish of statement handle
+# - after destruction of statement handle
+# Check the driver handle's kids:
+# - after creation of database handle
+# - after disconnection of database handle
+# - after destruction of database handle
## ----------------------------------------------------------------------------
## load DBI
@@ -19,47 +36,71 @@
use_ok('DBI');
}
-SKIP: {
- skip '$h->{Kids} attribute not supported for DBI::PurePerl', 10 if
($DBI::PurePerl);
+# Connect to the example driver and create a database handle
+my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
+ {
+ PrintError => 1,
+ RaiseError => 0
+ });
- # Connect to the example driver.
- my $dbh = DBI->connect('dbi:ExampleP:dummy', '', '',
- { PrintError => 0,
- RaiseError => 0,
- HandleError =>
\&test_kid
- });
- ok($dbh, '... got a database handle');
- isa_ok($dbh, 'DBI::db');
-
- # Raise an error.
- my $x = eval { $dbh->do('select foo from foo') };
-
- cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s)');
-
- my $drh = $dbh->{Driver};
- cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s)');
- cmp_ok( $drh->{ActiveKids}, '==', 1, '... database handle has 1 ActiveKid(s)');
-
- $dbh->disconnect;
- cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s) after
$dbh->disconnect');
- cmp_ok( $drh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s)
after $dbh->disconnect');
-
- undef $dbh;
- cmp_ok( $drh->{Kids}, '==', 0, '... driver handle has 0 Kid(s) after undef
$dbh');
- cmp_ok( $drh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s)
after undef $dbh');
-}
+# check our database handle to make sure its good
+isa_ok($dbh, 'DBI::db');
-sub test_kid {
- my ($err, $dbh, $retval) = @_;
- # Testing $dbh->{Kids} here is unstable because we would be relying on
- # when perl chooses to call DESTROY the lexical $sth created within prepare()
- # The HandleError sub doesn't get called until the do() is returning
- # and recent perl's (>=5.8.0) have destroyed the handle by then (quite
reasonably).
+# check that it has no Kids or ActiveKids yet
+cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) at start');
+cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) at
start');
- # When a HandleEvent attribute gets added to the DBI then we'll probably call that
- # at the moment the error is registered, and so we could test $sth->{Kids} then.
+# create a scope for our $sth to live and die in
+do {
- pass('... test_kid error handler running');
-}
+ # create a statement handle
+ my $sth = $dbh->prepare('select uid from ./');
+
+ # verify that it is a correct statement handle
+ isa_ok($sth, "DBI::st");
+
+ # check our Kids and ActiveKids after prepare
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after
$dbh->prepare');
+ cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s)
after $dbh->prepare');
+
+ $sth->execute();
+
+ # check our Kids and ActiveKids after execute
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after
$sth->execute');
+ cmp_ok($dbh->{ActiveKids}, '==', 1, '... database handle has 1 ActiveKid(s)
after $sth->execute');
+
+ $sth->finish();
+
+ # check our Kids and Activekids after finish
+ cmp_ok($dbh->{Kids}, '==', 1, '... database handle has 1 Kid(s) after
$sth->finish');
+ cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s)
after $sth->finish');
+
+};
+
+# now check it after the statement handle has been destroyed
+cmp_ok($dbh->{Kids}, '==', 0, '... database handle has 0 Kid(s) after $sth is
destroyed');
+cmp_ok($dbh->{ActiveKids}, '==', 0, '... database handle has 0 ActiveKid(s) after
$sth is destroyed');
+
+# get the database handles driver Driver
+my $drh = $dbh->{Driver};
+
+# check that is it a correct driver handle
+isa_ok($drh, "DBI::dr");
+
+# check the driver's Kids and ActiveKids
+cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s)');
+cmp_ok( $drh->{ActiveKids}, '==', 1, '... driver handle has 1 ActiveKid(s)');
+
+$dbh->disconnect;
+
+# check the driver's Kids and ActiveKids after $dbh->disconnect
+cmp_ok( $drh->{Kids}, '==', 1, '... driver handle has 1 Kid(s) after
$dbh->disconnect');
+cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after
$dbh->disconnect');
+
+undef $dbh;
+ok(!defined($dbh), '... lets be sure that $dbh is not undefined');
+
+# check the driver's Kids and ActiveKids after undef $dbh
+cmp_ok( $drh->{Kids}, '==', 0, '... driver handle has 0 Kid(s) after undef $dbh');
+cmp_ok( $drh->{ActiveKids}, '==', 0, '... driver handle has 0 ActiveKid(s) after
undef $dbh');
-1;
Modified: dbi/trunk/t/15array.t
==============================================================================
--- dbi/trunk/t/15array.t (original)
+++ dbi/trunk/t/15array.t Mon May 10 15:11:48 2004
@@ -1,157 +1,216 @@
-#!perl -w
+#!perl
use strict;
-use Test::More tests => 41;
+use warnings;
-use Data::Dumper;
-$Data::Dumper::Indent = 0;
-$Data::Dumper::Terse = 1;
+use Test::More tests => 42;
+
+## ----------------------------------------------------------------------------
+## 15array.t
+## ----------------------------------------------------------------------------
+#
+## ----------------------------------------------------------------------------
BEGIN {
use_ok('DBI');
}
-my $dbh = DBI->connect("dbi:Sponge:dummy", '', '', { RaiseError=>1, AutoCommit=>1 });
-ok($dbh);
+# create a database handle
+my $dbh = DBI->connect("dbi:Sponge:dummy", '', '',
+ {
+ RaiseError=>1,
+ AutoCommit=>1
+ });
+
+# check that our db handle is good
isa_ok($dbh, "DBI::db");
-my $rows = [ ];
+my $rows = [];
my $tuple_status = [];
my $dumped;
-#$dbh->trace(2);
-
my $sth = $dbh->prepare("insert", {
- rows => $rows, # where to 'insert' (push) the rows
- NUM_OF_PARAMS => 4,
- # DBD::Sponge hook to make certain data trigger an error for that row
- execute_hook => sub {
- local $^W;
- return $_[0]->set_err(1,"errmsg")
- if grep { $_ and $_ eq "B" } @_;
- return 1;
- },
-});
-ok($sth);
-
-cmp_ok(scalar @{$rows}, '==', 0);
-ok(!$sth->execute_array( { ArrayTupleStatus => $tuple_status },
- [ 1, 2, 3 ], # array of integers
- 42, # scalar 42 treated as array of 42's
- undef, # scalar undef treated as array of undef's
- [ qw(A B C) ], # array of strings
- )
+ rows => $rows, # where to 'insert' (push) the rows
+ NUM_OF_PARAMS => 4,
+ execute_hook => sub { # DBD::Sponge hook to make certain data
trigger an error for that row
+ local $^W;
+ return $_[0]->set_err(1,"errmsg") if grep { $_ and $_ eq "B" }
@_;
+ return 1;
+ }
+ });
+
+isa_ok($sth, "DBI::st");
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+
+# -----------------------------------------------
+
+ok(!$sth->execute_array(
+ {
+ ArrayTupleStatus => $tuple_status
+ },
+ [ 1, 2, 3 ], # array of integers
+ 42, # scalar 42 treated as array of 42's
+ undef, # scalar undef treated as array of
undef's
+ [ qw(A B C) ], # array of strings
+ ),
+ '... execute_array should return false'
);
-cmp_ok(scalar @{$rows}, '==', 2);
-cmp_ok(scalar @{$tuple_status}, '==', 3);
-
-$dumped = Dumper($rows);
-is( $dumped, "[[1,42,undef,'A'],[3,42,undef,'C']]"); # missing row containing B
-
-$dumped = Dumper($tuple_status);
-is( $dumped, "[1,[1,'errmsg','S1000'],1]"); # row containing B has error
+cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
+ok(eq_array(
+ $rows,
+ [ [1, 42, undef, 'A'], [3, 42, undef, 'C'] ]
+ ),
+ '... our rows are as expected');
+
+ok(eq_array(
+ $tuple_status,
+ [1, [1, 'errmsg', 'S1000'], 1]
+ ),
+ '... our tuple_status is as expected');
+# -----------------------------------------------
# --- change one param and re-execute
@$rows = ();
-ok( $sth->bind_param_array(4, [ qw(a b c) ]) );
-ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }) );
-
-cmp_ok(scalar @{$rows}, '==', 3);
-cmp_ok(scalar @{$tuple_status}, '==', 3);
+ok( $sth->bind_param_array(4, [ qw(a b c) ]), '... bind_param_array should return
true');
+ok( $sth->execute_array({ ArrayTupleStatus => $tuple_status }), '... execute_array
should return true');
-$dumped = Dumper($rows);
-ok( $dumped, "[[1,42,undef,'a'],[2,42,undef,'b'],[3,42,undef,'c']]");
+cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
-$dumped = Dumper($tuple_status);
-ok( $dumped, "[1,1,1]");
+ok(eq_array(
+ $rows,
+ [ [1, 42, undef, 'a'], [2, 42, undef, 'b'], [3, 42, undef, 'c'] ]
+ ),
+ '... our rows are as expected');
+
+ok(eq_array(
+ $tuple_status,
+ [1, 1, 1]
+ ),
+ '... our tuple_status is as expected');
+# -----------------------------------------------
# --- with no values for bind params, should execute zero times
@$rows = ();
-cmp_ok( $sth->execute_array( { ArrayTupleStatus => $tuple_status },
- [], [], [], [],
- ),
- '==', 0);
-cmp_ok(scalar @{$rows}, '==', 0);
-cmp_ok(scalar @{$tuple_status}, '==', 0);
+ok(!$sth->execute_array( { ArrayTupleStatus => $tuple_status }, [], [], [], []), '...
execute_array should return false');
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 0,'... we should have 0 tuple_status');
+
+# -----------------------------------------------
# --- catch 'undefined value' bug with zero bind values
@$rows = ();
my $sth_other = $dbh->prepare("insert", {
- rows => $rows, # where to 'insert' (push) the rows
+ rows => $rows, # where to 'insert' (push) the rows
NUM_OF_PARAMS => 1,
});
-cmp_ok( $sth_other->execute_array( {}, [] ), '==', 0); # no ArrayTupleStatus
-cmp_ok(scalar @{$rows}, '==', 0);
+isa_ok($sth_other, "DBI::st");
+
+ok(!$sth_other->execute_array( {}, [] ), '... execute_array should return false');
+# no ArrayTupleStatus
+
+cmp_ok(scalar @{$rows}, '==', 0, '... we should have 0 rows');
+
+# -----------------------------------------------
# --- ArrayTupleFetch code-ref tests ---
my $index = 0;
-my $fetchrow = sub { # generate 5 rows of two integer values
+
+my $fetchrow = sub { # generate 5 rows of two integer values
return if $index >= 2;
$index +=1;
# There doesn't seem any reliable way to force $index to be
# treated as a string (and so dumped as such). We just have to
# make the test case allow either 1 or '1'.
- #
return [ $index, 'a','b','c' ];
};
+
@$rows = ();
ok( $sth->execute_array({
- ArrayTupleFetch => $fetchrow,
- ArrayTupleStatus => $tuple_status,
-}) );
-cmp_ok(scalar @{$rows}, '==', 2);
-cmp_ok(scalar @{$tuple_status}, '==', 2);
-$dumped = Dumper($rows);
-$dumped =~ s/'(\d)'/$1/g;
-ok( $dumped, "[[1,'a','b','c'],[2,'a','b','c']]");
-$dumped = Dumper($tuple_status);
-ok( $dumped, "[1,1]");
+ ArrayTupleFetch => $fetchrow,
+ ArrayTupleStatus => $tuple_status
+ }), '... execute_array should return true');
+
+cmp_ok(scalar @{$rows}, '==', 2, '... we should have 2 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 2, '... we should have 2 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [1, 'a', 'b', 'c'], [2, 'a', 'b', 'c'] ]
+ ),
+ '... rows should match'
+);
+ok(eq_array(
+ $tuple_status,
+ [1, 1]
+ ),
+ '... tuple_status should match'
+);
+
+# -----------------------------------------------
# --- ArrayTupleFetch sth tests ---
my $fetch_sth = $dbh->prepare("foo", {
- rows => [ map { [ $_,'x','y','z' ] } 7..9 ],
- NUM_OF_FIELDS =>4
- #NAME =>
-});
+ rows => [ map { [ $_,'x','y','z' ] } 7..9 ],
+ NUM_OF_FIELDS => 4
+ });
+
+isa_ok($fetch_sth, "DBI::st");
+
$fetch_sth->execute();
+
@$rows = ();
+
ok( $sth->execute_array({
- ArrayTupleFetch => $fetch_sth,
- ArrayTupleStatus => $tuple_status,
-}) );
-cmp_ok(scalar @{$rows}, '==', 3);
-cmp_ok(scalar @{$tuple_status}, '==', 3);
-$dumped = Dumper($rows);
-ok( $dumped, "[[7,'x','y','z'],[8,'x','y','z'],[9,'x','y','z']]");
-$dumped = Dumper($tuple_status);
-ok( $dumped, "[1,1,1]");
+ ArrayTupleFetch => $fetch_sth,
+ ArrayTupleStatus => $tuple_status,
+ }), '... execute_array should return true');
+
+cmp_ok(scalar @{$rows}, '==', 3, '... we should have 3 rows');
+cmp_ok(scalar @{$tuple_status}, '==', 3, '... we should have 3 tuple_status');
+
+ok(eq_array(
+ $rows,
+ [ [7, 'x', 'y', 'z'], [8, 'x', 'y', 'z'], [9, 'x', 'y', 'z'] ]
+ ),
+ '... rows should match'
+);
+
+ok(eq_array(
+ $tuple_status,
+ [1, 1, 1]
+ ),
+ '... tuple status should match'
+);
+# -----------------------------------------------
# --- error detection tests ---
$sth->{RaiseError} = 0;
$sth->{PrintError} = 0;
-#$sth->trace(2);
-is( $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]), undef );
-is( $sth->errstr, '2 bind values supplied but 4 expected' );
+ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, [1],[2]),
'... execute_array should return undef');
+is($sth->errstr, '2 bind values supplied but 4 expected', '... errstr is as
expected');
-is( $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), undef );
-is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref' );
+ok(!defined $sth->execute_array( { ArrayTupleStatus => { } }, [ 1, 2, 3 ]), '...
execute_array should return undef');
+is( $sth->errstr, 'ArrayTupleStatus attribute must be an arrayref', '... errstr is as
expected');
-is( $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4), undef );
-is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a HASH'
);
+ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,{},3,4),
'... execute_array should return undef');
+is( $sth->errstr, 'Value for parameter 2 must be a scalar or an arrayref, not a
HASH', '... errstr is as expected');
-is( $sth->execute_array( { ArrayTupleStatus => $tuple_status }, 1,[1],[2,2],3), undef
);
-is( $sth->errstr, 'Arrayref for parameter 3 has 2 elements but parameter 2 has 1' );
+ok(!defined $sth->execute_array( { ArrayTupleStatus => $tuple_status },
1,[1],[2,2],3), '... execute_array should return undef');
+is( $sth->errstr, 'Arrayref for parameter 3 has 2 elements but parameter 2 has 1',
'... errstr is as expected');
-is( $sth->bind_param_array(":foo", [ qw(a b c) ]), undef );
-is( $sth->errstr, "Can't use named placeholders for non-driver supported
bind_param_array");
+ok(!defined $sth->bind_param_array(":foo", [ qw(a b c) ]), '... bind_param_array
should return undef');
+is( $sth->errstr, "Can't use named placeholders for non-driver supported
bind_param_array", '... errstr is as expected');
1;
