Author: byterock
Date: Wed Jul 23 07:19:48 2008
New Revision: 11577
Modified:
dbd-oracle/trunk/Changes
dbd-oracle/trunk/t/01base.t
dbd-oracle/trunk/t/10general.t
dbd-oracle/trunk/t/12impdata.t
dbd-oracle/trunk/t/15nls.t
dbd-oracle/trunk/t/20select.t
dbd-oracle/trunk/t/21nchar.t
dbd-oracle/trunk/t/22nchar_al32utf8.t
dbd-oracle/trunk/t/22nchar_utf8.t
dbd-oracle/trunk/t/23wide_db_al32utf8.t
dbd-oracle/trunk/t/24implicit_utf8.t
dbd-oracle/trunk/t/25plsql.t
dbd-oracle/trunk/t/30long.t
dbd-oracle/trunk/t/34pres_lobs.t
dbd-oracle/trunk/t/40ph_type.t
dbd-oracle/trunk/t/50cursor.t
dbd-oracle/trunk/t/51scroll.t
dbd-oracle/trunk/t/55nested.t
dbd-oracle/trunk/t/60reauth.t
dbd-oracle/trunk/t/70meta.t
dbd-oracle/trunk/t/nchar_test_lib.pl
Log:
Fix to test suite to bring it up to standard from Martin Evans
Modified: dbd-oracle/trunk/Changes
==============================================================================
--- dbd-oracle/trunk/Changes (original)
+++ dbd-oracle/trunk/Changes Wed Jul 23 07:19:48 2008
@@ -1,4 +1,5 @@
=head1 Changes in DBD-Oracle 1.22(svn rev xxxx) 2008
+ Fix to test suite to bring it up to standard from Martin Evans
Fix for memory hemorrhage in bind_param_inout_array found by Ricky Egeland, Fix by John Scoles
Fix for a typo in oracle.xs from Milo van der Leij
Fix for bugs on SPs with Lobs reported by Martin Evans, Fix by J Scoles
Modified: dbd-oracle/trunk/t/01base.t
==============================================================================
--- dbd-oracle/trunk/t/01base.t (original)
+++ dbd-oracle/trunk/t/01base.t Wed Jul 23 07:19:48 2008
@@ -1,28 +1,28 @@
#!perl -w
# Base DBD Driver Test
+use Test::More tests => 6;
-print "1..$tests\n";
+diag('Test loading DBI, DBD::Oracle and version');
+require_ok(DBI);
-require DBI;
-print "ok 1\n";
-
-import DBI;
-print "ok 2\n";
+eval {
+ import DBI;
+};
+ok(!$@, 'import DBI');
$switch = DBI->internal;
-(ref $switch eq 'DBI::dr') ? print "ok 3\n" : print "not ok 3\n";
+is(ref $switch, 'DBI::dr', 'internal');
eval {
-
-# This is a special case. install_driver should not normally be used.
-$drh = DBI->install_driver('Oracle');
-(ref $drh eq 'DBI::dr') ? print "ok 4\n" : print "not ok 4\n";
-
+ # This is a special case. install_driver should not normally be used.
+ $drh = DBI->install_driver('Oracle');
};
-if ($@) {
- $@ =~ s/\n\n+/\n/g if $@;
- warn "Failed to load Oracle extension and/or shared libraries:\n$@" if $@;
+my $ev = $@;
+ok(!$ev, 'install_driver');
+if ($ev) {
+ $ev =~ s/\n\n+/\n/g;
+ warn "Failed to load Oracle extension and/or shared libraries:\n$@";
warn "The remaining tests will probably also fail with the same error.\a\n\n";
# try to provide some useful pointers for some cases
if ($@ =~ /Solaris patch.*Java/i) {
@@ -32,13 +32,18 @@
warn "*** Please read the README and README.help.txt files for help. ***\n";
}
warn "\n";
- sleep 5;
+ sleep 5;
+
}
-print "ok 5\n" if $drh->{Version};
+SKIP: {
+ skip 'install_driver failed - skipping remaining', 2 if $ev;
+
+ is(ref $drh, 'DBI::dr', 'install_driver');
+
+ ok($drh->{Version}, 'version');
+}
-BEGIN { $tests = 5 }
-exit 0;
# end.
__END__
Modified: dbd-oracle/trunk/t/10general.t
==============================================================================
--- dbd-oracle/trunk/t/10general.t (original)
+++ dbd-oracle/trunk/t/10general.t Wed Jul 23 07:19:48 2008
@@ -15,63 +15,64 @@
plan tests => 31;
+diag('Test preparsing, Active, NLS_NUMERIC_CHARACTERS, err, ping and OCI version');
+
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '');
unless($dbh) {
- BAILOUT("Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n");
- exit 0;
+ BAILOUT("Unable to connect to Oracle ($DBI::errstr)\nTests skipped.\n");
+ exit 0;
}
my($sth, $p1, $p2, $tmp);
SKIP: {
- skip "not unix-like", 2 unless $Config{d_semctl};
- skip "solaris with OCI>9.x", 2 unless ($^O eq "solaris") and (scalar(ORA_OCI) ge 10);
-
- # basic check that we can fork subprocesses and wait for the status
- # after having connected to Oracle
-
- is system("exit 1;"), 1<<8, 'system exit 1 should return 256';
- is system("exit 0;"), 0, 'system exit 0 should return 0';
-
-}
+ skip "not unix-like", 2 unless $Config{d_semctl};
+ skip "solaris with OCI>9.x", 2 unless ($^O eq "solaris") and (scalar(ORA_OCI) ge 10);
+ # basic check that we can fork subprocesses and wait for the status
+ # after having connected to Oracle
+
+ is system("exit 1;"), 1<<8, 'system exit 1 should return 256';
+ is system("exit 0;"), 0, 'system exit 0 should return 0';
+}
$sth = $dbh->prepare(q{
/* also test preparse doesn't get confused by ? :1 */
/* also test placeholder binding is case insensitive */
select :a, :A from user_tables -- ? :1
});
-ok($sth->{ParamValues});
-is(keys %{$sth->{ParamValues}}, 1);
-is($sth->{NUM_OF_PARAMS}, 1);
-ok($sth->bind_param(':a', 'a value'));
-ok($sth->execute);
-ok($sth->{NUM_OF_FIELDS});
+ok($sth->{ParamValues}, 'preparse, case insensitive, placeholders in comments');
+is(keys %{$sth->{ParamValues}}, 1, 'number of parameters');
+is($sth->{NUM_OF_PARAMS}, 1, 'expected number of parameters');
+ok($sth->bind_param(':a', 'a value'), 'bind_param for select parameter');
+ok($sth->execute, 'execute for select parameter');
+ok($sth->{NUM_OF_FIELDS}, 'NUM_OF_FIELDS');
eval {
local $SIG{__WARN__} = sub { die @_ }; # since DBI 1.43
$p1=$sth->{NUM_OFFIELDS_typo};
};
-ok($@ =~ /attribute/);
-ok($sth->{Active});
-ok($sth->finish);
-ok(!$sth->{Active});
+ok($@ =~ /attribute/, 'unrecognised attribute');
+ok($sth->{Active}, 'statement is active');
+ok($sth->finish, 'finish');
+ok(!$sth->{Active}, 'statement is not active');
$sth = $dbh->prepare("select * from user_tables");
-ok($sth->execute);
-ok($sth->{Active});
+ok($sth->execute, 'execute for user_tables');
+ok($sth->{Active}, 'active for user_tables');
1 while ($sth->fetch); # fetch through to end
-ok(!$sth->{Active});
+ok(!$sth->{Active}, 'user_tables not active after fetch');
# so following test works with other NLS settings/locations
-ok($dbh->do("ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'"));
+ok($dbh->do("ALTER SESSION SET NLS_NUMERIC_CHARACTERS = '.,'"),
+ 'set NLS_NUMERIC_CHARACTERS');
ok($tmp = $dbh->selectall_arrayref(q{
select 1 * power(10,-130) "smallest?",
9.9999999999 * power(10,125) "biggest?"
from dual
-}));
+}), 'select all for arithmetic');
my @tmp = @{$tmp->[0]};
#warn "@tmp"; $tmp[0]+=0; $tmp[1]+=0; warn "@tmp";
ok($tmp[0] <= 1.0000000000000000000000000000000001e-130, "tmp0=$tmp[0]");
@@ -87,26 +88,28 @@
ok($@ =~ /DBD::Oracle::db do failed:/, "eval error: ``$@'' expected 'do failed:'");
#print "''$warn''";
ok($warn =~ /DBD::Oracle::db do failed:/, "warn error: ``$warn'' expected 'do failed:'");
-ok($DBI::err);
-ok($ora_errno);
-is($ora_errno, $DBI::err);
+ok($DBI::err, 'err defined');
+ok($ora_errno, 'ora_errno defined');
+is($ora_errno, $DBI::err, 'ora_errno and err equal');
$dbh->{RaiseError} = 0;
# ---
-ok( $dbh->ping);
+ok( $dbh->ping, 'ping - connected');
$dbh->disconnect;
$dbh->{PrintError} = 0;
-ok(!$dbh->ping);
+ok(!$dbh->ping, 'ping disconnected');
my $ora_oci = DBD::Oracle::ORA_OCI(); # dualvar
printf "ORA_OCI = %d (%s)\n", $ora_oci, $ora_oci;
-ok("$ora_oci");
-ok($ora_oci >= 8);
+ok("$ora_oci", 'ora_oci defined');
+ok($ora_oci >= 8, 'ora_oci >= 8');
+diag($ora_oci);
my @ora_oci = split(/\./, $ora_oci,-1);
-ok(scalar @ora_oci >= 2);
-ok(scalar @ora_oci == grep { DBI::looks_like_number($_) } @ora_oci);
-is($ora_oci[0], int($ora_oci));
+ok(scalar @ora_oci >= 2, 'version has 2 or more components');
+ok((scalar @ora_oci == grep { DBI::looks_like_number($_) } @ora_oci),
+ 'version looks like numbers');
+is($ora_oci[0], int($ora_oci), 'first number is int');
exit 0;
Modified: dbd-oracle/trunk/t/12impdata.t
==============================================================================
--- dbd-oracle/trunk/t/12impdata.t (original)
+++ dbd-oracle/trunk/t/12impdata.t Wed Jul 23 07:19:48 2008
@@ -3,12 +3,13 @@
## ----------------------------------------------------------------------------
## 12imptdata.t
-## By Jeffrey Klein,
+## By Jeffrey Klein,
## ----------------------------------------------------------------------------
use strict;
use DBI;
use Config qw(%Config);
+# must be done before Test::More - see Threads in Test::More pod
BEGIN { eval "use threads; use threads::shared;" }
my $use_threads_err = $@;
use Test::More;
Modified: dbd-oracle/trunk/t/15nls.t
==============================================================================
--- dbd-oracle/trunk/t/15nls.t (original)
+++ dbd-oracle/trunk/t/15nls.t Wed Jul 23 07:19:48 2008
@@ -13,6 +13,7 @@
$| = 1;
+diag('test nls_date_format, ora_can_unicode');
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
Modified: dbd-oracle/trunk/t/20select.t
==============================================================================
--- dbd-oracle/trunk/t/20select.t (original)
+++ dbd-oracle/trunk/t/20select.t Wed Jul 23 07:19:48 2008
@@ -1,5 +1,5 @@
#!perl -w
-
+use Test::More;
use DBI;
use DBD::Oracle qw(:ora_types ORA_OCI);
use Data::Dumper;
@@ -9,9 +9,23 @@
unshift @INC ,'t';
require 'nchar_test_lib.pl';
-sub ok ($$;$);
-
$| = 1;
+
+my @test_sets = (
+ [ "CHAR(10)", 10 ],
+ [ "VARCHAR(10)", 10 ],
+ [ "VARCHAR2(10)", 10 ],
+);
+
+# Set size of test data (in 10KB units)
+# Minimum value 3 (else tests fail because of assumptions)
+# Normal value 8 (to test 64KB threshold well)
+my $sz = 8;
+
+my $tests = 3;
+my $tests_per_set = 11;
+$tests += @test_sets * $tests_per_set;
+
my $t = 0;
my $failed = 0;
my %ocibug;
@@ -25,133 +39,116 @@
PrintError => 0,
});
-unless($dbh) {
- warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n";
- print "1..0\n";
- exit 0;
+if ($dbh) {
+ plan tests=>$tests;
+} else {
+ plan skip_all => "Unable to connect to oracle ($DBI::errstr)\n";
}
+diag('test simple select statements with [utf8]');
my $utf8_test = ($] >= 5.006)
&& client_ochar_is_utf8() # for correct output (utf8 bind vars should be fine regardless)
&& ($dbh->ora_can_unicode() & 2);
-print "Including unicode test\n" if $utf8_test;
+diag("Including unicode data in test") if $utf8_test;
unless(create_test_table("str CHAR(10)", 1)) {
- warn "Unable to create test table ($DBI::errstr)\nTests skiped.\n";
+ BAIL_OUT("Unable to create test table ($DBI::errstr)\n");
print "1..0\n";
exit 0;
}
-
-my @test_sets = (
- [ "CHAR(10)", 10 ],
- [ "VARCHAR(10)", 10 ],
- [ "VARCHAR2(10)", 10 ],
-);
-
-# Set size of test data (in 10KB units)
-# Minimum value 3 (else tests fail because of assumptions)
-# Normal value 8 (to test 64KB threshold well)
-my $sz = 8;
-
-my $tests = 3;
-my $tests_per_set = 11;
-$tests += @test_sets * $tests_per_set;
-print "1..$tests\n";
-
my($sth, $p1, $p2, $tmp, @tmp);
-#$dbh->trace(4);
foreach (@test_sets) {
run_select_tests( @$_ );
}
-
-sub run_select_tests {
- my ($type_name, $field_len) = @_;
-
- my $data0;
- if ($utf8_test) {
- $data0 = eval q{ "0\x{263A}xyX" }; #this includes the smiley from perlunicode (lab) BTW: it is busted
- } else {
- $data0 = "0\177x\0X";
- }
- my $data1 = "1234567890";
- my $data2 = "2bcdefabcd";
-
- if (!create_test_table("lng $type_name", 1)) {
- # typically OCI 8 client talking to Oracle 7 database
- warn "Unable to create test table for '$type_name' data ($DBI::err). Tests skipped.\n";
- foreach (1..$tests_per_set) { ok(0, 1) }
- return;
- }
-
- print " --- insert some $type_name data\n";
- ok(0, $sth = $dbh->prepare("insert into $table values (?, ?, SYSDATE)"), 1);
- ok(0, $sth->execute(40, $data0), 1);
- ok(0, $sth->execute(Math::BigInt->new(41), $data1), 1); # bind an overloaded value
- ok(0, $sth->execute(42, $data2), 1);
-
- print " --- try to insert a string that's too long\n";
- ok(0, !$sth->execute(43, "12345678901234567890"), 1);
-
- print " --- fetch $type_name data back again\n";
-
- ok(0, $sth = $dbh->prepare("select * from $table order by idx"), 1);
- ok(0, $sth->execute, 1);
- ok(0, $tmp = $sth->fetchall_arrayref, 1);
- # allow for padded blanks
- ok(0, $tmp->[0][1] =~ m/$data0/,
- cdif($tmp->[0][1], $data0, "Len ".length($tmp->[0][1])) );
- ok(0, $tmp->[1][1] =~ m/$data1/,
- cdif($tmp->[1][1], $data1, "Len ".length($tmp->[1][1])) );
- ok(0, $tmp->[2][1] =~ m/$data2/,
- cdif($tmp->[2][1], $data2, "Len ".length($tmp->[2][1])) );
-
-
-} # end of run_select_tests
-
- my $ora_server_version = $dbh->func("ora_server_version");
- if ($ora_server_version->[0] < 10) {
- ok(0, 1, 1); # skip
- } else {
+my $ora_server_version = $dbh->func("ora_server_version");
+SKIP: {
+ skip "Oracle < 10", 1 if ($ora_server_version->[0] < 10);
my $data = $dbh->selectrow_array(q!
select to_dsinterval(?) from dual
!, {}, "1 07:00:00");
- ok (0, (defined $data and $data eq '+000000001 07:00:00.000000000'), 1);
+ ok ((defined $data and $data eq '+000000001 07:00:00.000000000'),
+ "ds_interval");
}
-if (0) { # UNION ALL causes Oracle 9 (not 8) to describe col1 as zero length
-# causing "ORA-24345: A Truncation or null fetch error occurred" error
-# Looks like an Oracle bug
-$dbh->trace(9);
-ok 0, $sth = $dbh->prepare(qq{
+if (0) {
+ # UNION ALL causes Oracle 9 (not 8) to describe col1 as zero length
+ # causing "ORA-24345: A Truncation or null fetch error occurred" error
+ # Looks like an Oracle bug
+ $dbh->trace(9);
+ ok 0, $sth = $dbh->prepare(qq{
SELECT :HeadCrncy FROM DUAL
UNION ALL
- SELECT :HeadCrncy FROM DUAL
-});
-$dbh->trace(0);
-ok 0, $sth->execute("EUR");
-ok 0, $tmp = $sth->fetchall_arrayref;
-use Data::Dumper;
-die Dumper $tmp;
+ SELECT :HeadCrncy FROM DUAL});
+ $dbh->trace(0);
+ ok 0, $sth->execute("EUR");
+ ok 0, $tmp = $sth->fetchall_arrayref;
+ use Data::Dumper;
+ die Dumper $tmp;
}
# $dbh->{USER} is just there so it works for old DBI's before Username was added
my @pk = $dbh->primary_key(undef, $dbh->{USER}||$dbh->{Username}, uc $table);
-print "primary_key($table): ".Dumper(\@pk);
-ok(0, @pk);
-ok(0, join(",",@pk) eq 'DT,IDX');
+ok(@pk, 'primary key on table');
+is(join(",",@pk), 'DT,IDX', 'DT,IDX');
exit 0;
+
END {
$dbh->do(qq{ drop table $table }) if $dbh;
}
-# end.
+sub run_select_tests {
+ my ($type_name, $field_len) = @_;
+
+ my $data0;
+ if ($utf8_test) {
+ $data0 = eval q{ "0\x{263A}xyX" }; #this includes the smiley from perlunicode (lab) BTW: it is busted
+ } else {
+ $data0 = "0\177x\0X";
+ }
+ my $data1 = "1234567890";
+ my $data2 = "2bcdefabcd";
+
+ SKIP: {
+ if (!create_test_table("lng $type_name", 1)) {
+ # typically OCI 8 client talking to Oracle 7 database
+ diag("Unable to create test table for '$type_name' data ($DBI::err)");
+ skip $tests_per_set;
+ }
+
+ $sth = $dbh->prepare("insert into $table values (?, ?, SYSDATE)");
+ ok($sth, "prepare for insert of $type_name");
+ ok($sth->execute(40, $data0), "insert 8bit or utf8");
+ ok($sth->execute(Math::BigInt->new(41), $data1), 'bind overloaded value');
+ ok($sth->execute(42, $data2), "insert data2");
+
+ ok(!$sth->execute(43, "12345678901234567890"), 'insert string too long');
+
+ ok($sth = $dbh->prepare("select * from $table order by idx"),
+ "prepare select ordered by idx");
+ ok($sth->execute, "execute");
+ # allow for padded blanks
+ $sth->{ChopBlanks} = 1;
+ ok($tmp = $sth->fetchall_arrayref, 'fetchall');
+ my $dif;
+ $dif = DBI::data_diff($tmp->[0][1], $data0);
+ ok(!$dif, 'first row matches');
+ diag($dif) if $dif;
+ $dif = DBI::data_diff($tmp->[1][1], $data1);
+ ok(!$dif, 'second row matches');
+ diag($dif) if $dif;
+ $dif = DBI::data_diff($tmp->[2][1], $data2);
+ ok(!$dif, 'third row matches');
+ diag($dif) if $dif;
+ }
+} # end of run_select_tests
+
+# end.
-# ----
sub create_test_table {
my ($fields, $drop) = @_;
@@ -169,45 +166,7 @@
$dbh->do($sql);
}
return 0 if $dbh->err;
- print "$sql\n";
return 1;
}
-
-sub cdif {
- my ($s1, $s2, $msg) = @_;
- $msg = ($msg) ? ", $msg" : "";
- my ($l1, $l2) = (length($s1), length($s2));
- return "Strings are identical$msg" if $s1 eq $s2;
- return "Strings are of different lengths ($l1 vs $l2)($s1 vs $s2)$msg" # check substr matches?
- if $l1 != $l2;
-
- my $i;
- for($i=0; $i < $l1; ++$i) {
- my ($c1,$c2) = (ord(substr($s1,$i,1)), ord(substr($s2,$i,1)));
- next if $c1 == $c2;
- return sprintf "Strings differ at position %d (\\%03o vs \\%03o)$msg",
- $i,$c1,$c2;
- }
- return "(cdif error $l1/$l2/$i)";
-}
-
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- $warn ||= '';
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- if ($ok) {
- print "ok $t\n";
- }
- else {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "# failed test $t at line ".(caller)[2].". $warn\n";
- print "not ok $t\n";
- ++$failed;
- }
-}
-
__END__
Modified: dbd-oracle/trunk/t/21nchar.t
==============================================================================
--- dbd-oracle/trunk/t/21nchar.t (original)
+++ dbd-oracle/trunk/t/21nchar.t Wed Jul 23 07:19:48 2008
@@ -19,8 +19,9 @@
$dbh = db_handle();
plan skip_all => "Not connected to oracle" if not $dbh;
- print STDERR " Database and client versions and character sets:\n";
- show_db_charsets( $dbh, \*STDERR ); # STDERR so we can see it in initial bug reports
+ diag("testing control and 8 bit chars:\n") ;
+ diag(" Database and client versions and character sets:\n");
+ show_db_charsets( $dbh);
plan skip_all => "Oracle charset tests unreliable for Oracle 8 client"
if ORA_OCI() < 9.0 and !$ENV{DBD_ALL_TESTS};
@@ -37,7 +38,6 @@
set_nls_nchar( $ncharset ,1 );
$dbh = db_handle();
- print "testing control and 8 bit chars:\n" ;
my $tdata = test_data( 'narrow_nchar' );
my $testcount = 0 #create table
+ insert_test_count( $tdata )
Modified: dbd-oracle/trunk/t/22nchar_al32utf8.t
==============================================================================
--- dbd-oracle/trunk/t/22nchar_al32utf8.t (original)
+++ dbd-oracle/trunk/t/22nchar_al32utf8.t Wed Jul 23 07:19:48 2008
@@ -33,7 +33,7 @@
+ select_test_count( $tdata ) * 1;
;
- plan tests => $testcount;
+ plan tests => $testcount;
show_test_data( $tdata ,0 );
drop_table($dbh);
create_table( $dbh, $tdata );
Modified: dbd-oracle/trunk/t/22nchar_utf8.t
==============================================================================
--- dbd-oracle/trunk/t/22nchar_utf8.t (original)
+++ dbd-oracle/trunk/t/22nchar_utf8.t Wed Jul 23 07:19:48 2008
@@ -24,14 +24,14 @@
plan skip_all => "Not connected to oracle" if not $dbh;
plan skip_all => "Database NCHAR character set is not Unicode" if not db_nchar_is_utf($dbh) ;
- print "testing utf8 with nchar columns\n" ;
+ diag("testing utf8 with nchar columns\n");
show_db_charsets( $dbh );
my $tdata = test_data( 'wide_nchar' );
if ( $dbh->ora_can_unicode & 1 ) {
push( @{$tdata->{rows}} ,extra_wide_rows() ) ;
- print " --- added 2 rows with extra wide chars to test data\n" ;
+ diag(" --- added 2 rows with extra wide chars to test data\n");
}
my $testcount = 0 #create table
@@ -39,7 +39,7 @@
+ select_test_count( $tdata ) * 1;
;
- plan tests => $testcount;
+ plan tests => $testcount;
show_test_data( $tdata ,0 );
drop_table($dbh);
create_table( $dbh, $tdata );
Modified: dbd-oracle/trunk/t/23wide_db_al32utf8.t
==============================================================================
--- dbd-oracle/trunk/t/23wide_db_al32utf8.t (original)
+++ dbd-oracle/trunk/t/23wide_db_al32utf8.t Wed Jul 23 07:19:48 2008
@@ -25,7 +25,7 @@
plan skip_all => "Not connected to oracle" if not $dbh;
plan skip_all => "Database character set is not Unicode" if not db_ochar_is_utf($dbh) ;
- print "testing utf8 with char columns (wide mode database)\n" ;
+ diag("testing utf8 with char columns (wide mode database)\n") ;
my $tdata = test_data( 'wide_char' );
my $testcount = 0 #create table
@@ -33,7 +33,7 @@
+ select_test_count( $tdata ) * 1;
;
- plan tests => $testcount;
+ plan tests => $testcount;
show_test_data( $tdata ,0 );
drop_table($dbh);
create_table( $dbh, $tdata );
Modified: dbd-oracle/trunk/t/24implicit_utf8.t
==============================================================================
--- dbd-oracle/trunk/t/24implicit_utf8.t (original)
+++ dbd-oracle/trunk/t/24implicit_utf8.t Wed Jul 23 07:19:48 2008
@@ -23,7 +23,7 @@
plan skip_all => "Database NCHAR character set is not Unicode" if not db_nchar_is_utf($dbh) ;
$dbh->disconnect();
- print " --- testing implicit csform (dbhimp.c sets csform implicitly)\n" ;
+ diag(" --- testing implicit csform (dbhimp.c sets csform implicitly)\n") ;
my $tdata = test_data( 'wide_nchar' );
my $testcount = 0
+ insert_test_count( $tdata )
@@ -37,7 +37,7 @@
foreach my $nchar_cset (@nchar_cset) {
$dbh->disconnect() if $dbh;
undef $dbh;
- print " --- testing with NLS_NCHAR=$nchar_cset\n" ;
+ diag(" --- testing with NLS_NCHAR=$nchar_cset\n") ;
SKIP: {
set_nls_nchar( $nchar_cset ,1 );
$dbh = db_handle();
Modified: dbd-oracle/trunk/t/25plsql.t
==============================================================================
--- dbd-oracle/trunk/t/25plsql.t (original)
+++ dbd-oracle/trunk/t/25plsql.t Wed Jul 23 07:19:48 2008
@@ -1,17 +1,5 @@
#!perl -w
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
+use Test::More;
use DBI;
use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
@@ -26,66 +14,60 @@
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', { PrintError => 0 });
-unless($dbh) {
- warn "Unable to connect to Oracle ($DBI::errstr)\nTests skiped.\n";
- print "1..0\n";
- exit 0;
-}
-
-# ORA-00900: invalid SQL statement
-# ORA-06553: PLS-213: package STANDARD not accessible
-my $tst = $dbh->prepare(q{declare foo char(50); begin RAISE INVALID_NUMBER; end;});
-if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) {
- warn "Your Oracle server doesn't support PL/SQL" if $dbh->err== 900;
- warn "Your Oracle PL/SQL is not properly installed" if $dbh->err==6553||$dbh->err==600;
- warn "Tests skipped\n";
- print "1..0\n";
- exit 0;
+if ($dbh) {
+ # ORA-00900: invalid SQL statement
+ # ORA-06553: PLS-213: package STANDARD not accessible
+ my $tst = $dbh->prepare(q{declare foo char(50); begin RAISE INVALID_NUMBER; end;});
+ if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) {
+ diag("Your Oracle server doesn't support PL/SQL") if $dbh->err== 900;
+ diag("Your Oracle PL/SQL is not properly installed")
+ if $dbh->err==6553||$dbh->err==600;
+ plan skip_all => 'Oracle server either does not support pl/sql or it is not properly installed';
+ }
+ plan tests=>82;
+} else {
+ plan skip_all => "Unable to connect to Oracle ($DBI::errstr)\n";
}
-my $tests;
-print "1..$tests\n";
my($csr, $p1, $p2, $tmp, @tmp);
#DBI->trace(4,"trace.log");
# --- test raising predefined exception
-ok(0, $csr = $dbh->prepare(q{
- begin RAISE INVALID_NUMBER; end;
-}), 1);
+ok($csr = $dbh->prepare(q{
+ begin RAISE INVALID_NUMBER; end;}), 'prepare raising predefined exception');
# ORA-01722: invalid number
-ok(0, ! $csr->execute, 1);
-ok(0, $DBI::err == 1722);
-ok(0, $DBI::err == 1722); # make sure error doesn't get cleared
+ok(! $csr->execute, 'execute predefined exception');
+is($DBI::err, 1722, 'err expected 1722 error');
+is($DBI::err, 1722, 'err does not get cleared');
# --- test raising user defined exception
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
DECLARE FOO EXCEPTION;
- begin raise FOO; end;
-}), 1);
+ begin raise FOO; end;}), 'prepare user defined expcetion');
# ORA-06510: PL/SQL: unhandled user-defined exception
-ok(0, ! $csr->execute, 1);
-ok(0, $DBI::err == 6510);
+ok(! $csr->execute, 'execute user defined exception');
+is($DBI::err, 6510, 'user exception 6510 error');
# --- test raise_application_error with literal values
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
declare err_num number; err_msg char(510);
- begin RAISE_APPLICATION_ERROR(-20101,'app error'); end;
-}), 1);
+ begin RAISE_APPLICATION_ERROR(-20101,'app error'); end;}),
+ 'prepare raise application error with literal values');
# ORA-20101: app error
-ok(0, ! $csr->execute, 1);
-ok(0, $DBI::err == 20101);
-ok(0, $DBI::errstr =~ m/app error/);
+ok(! $csr->execute, 'execite raise application error with literal values');
+is($DBI::err, 20101, 'expected 20101 error');
+like($DBI::errstr, qr/app error/, 'app error');
# --- test raise_application_error with 'in' parameters
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
declare err_num varchar2(555); err_msg varchar2(510);
--declare err_num number; err_msg char(510);
begin
@@ -93,107 +75,108 @@
err_msg := :2;
raise_application_error(-20000-err_num, 'msg is '||err_msg);
end;
-}), 1);
+}), 'prepare raise application error with in params');
-ok(0, ! $csr->execute(42, "hello world"), 1);
-ok(0, $DBI::err == 20042, $DBI::err);
-ok(0, $DBI::errstr =~ m/msg is hello world/, 1);
+ok(! $csr->execute(42, "hello world"),
+ 'execute raise application error with in params');
+is($DBI::err, 20042, 'expected 20042 error');
+like($DBI::errstr, qr/msg is hello world/, 'hello world msg');
# --- test named numeric in/out parameters
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
begin
:arg := :arg * :mult;
- end;
-}), 1);
+ end;}), 'prepare named numeric in/out params');
$p1 = 3;
-ok(0, $csr->bind_param_inout(':arg', \$p1, 50), 1);
-ok(0, $csr->bind_param(':mult', 2), 1);
-ok(0, $csr->execute, 1);
-ok(0, $p1 == 6);
+ok($csr->bind_param_inout(':arg', \$p1, 50), 'bind arg');
+ok($csr->bind_param(':mult', 2), 'bind mult');
+ok($csr->execute, 'execute named numeric in/out params');
+is($p1, 6, 'expected 3 * 3 = 6');
# execute 10 times from $p1=1, 2, 4, 8, ... 1024
-$p1 = 1; foreach (1..10) { $csr->execute || die $DBI::errstr; }
-ok(0, $p1 == 1024);
+$p1 = 1;
+eval {
+ foreach (1..10) { $csr->execute || die $DBI::errstr; };
+};
+my $ev = $@;
+ok(!$ev, 'execute named numeric in/out params 10 times');
+is($p1, 1024, 'expected p1 = 1024');
# --- test undef parameters
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
declare foo char(500);
- begin foo := :arg; end;
-}), 1);
+ begin foo := :arg; end;}), 'prepare undef parameters');
my $undef;
-ok(0, $csr->bind_param_inout(':arg', \$undef,10), 1);
-ok(0, $csr->execute, 1);
-
+ok($csr->bind_param_inout(':arg', \$undef,10), 'bind arg');
+ok($csr->execute, 'execute undef parameters');
# --- test named string in/out parameters
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
declare str varchar2(1000);
begin
:arg := nvl(upper(:arg), 'null');
:arg := :arg || :append;
- end;
-}), 1);
+ end;}), 'prepare named string in/out parameters');
undef $p1;
$p1 = "hello world";
-ok(0, $csr->bind_param_inout(':arg', \$p1, 1000), 1);
-ok(0, $csr->bind_param(':append', "!"), 1);
-ok(0, $csr->execute, 1);
-ok(0, $p1 eq "HELLO WORLD!");
+ok($csr->bind_param_inout(':arg', \$p1, 1000), 'bind arg');
+ok($csr->bind_param(':append', "!"), 'bind append');
+ok($csr->execute, 'execute named string in/out parameters');
+is($p1, "HELLO WORLD!", 'expected HELLO WORLD');
# execute 10 times growing $p1 to force realloc
-foreach (1..10) {
- $p1 .= " xxxxxxxxxx";
- $csr->execute || die $DBI::errstr;
-}
+eval {
+ foreach (1..10) {
+ $p1 .= " xxxxxxxxxx";
+ $csr->execute || die $DBI::errstr;
+ };
+};
+$ev = $@;
+ok(!$ev, 'execute named string in/out parameters 1- times');
my $expect = "HELLO WORLD!" . (" XXXXXXXXXX!" x 10);
-ok(0, $p1 eq $expect);
-
+is($p1, $expect, 'p1 as expected');
# --- test binding a null and getting a string back
undef $p1;
-ok(0, $csr->execute, 1);
-ok(0, $p1 eq 'null!');
+ok($csr->execute, 'execute binding a null');
+is($p1, 'null!', 'get a null string back');
$csr->finish;
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
begin
:out := nvl(upper(:in), 'null');
- end;
-}), 1);
+ end;}), 'prepare nvl');
#$csr->trace(3);
my $out;
-ok(0, $csr->bind_param_inout(':out', \$out, 1000), 1);
-
-ok(0, $csr->bind_param(':in', "foo", DBI::SQL_CHAR()), 1);
-ok(0, $csr->execute, 1);
-ok(0, $out eq "FOO");
-
-ok(0, $csr->bind_param(':in', ""), 1);
-ok(0, $csr->execute, 1);
-ok(0, $out eq "null");
-
+ok($csr->bind_param_inout(':out', \$out, 1000), 'bind out');
+ok($csr->bind_param(':in', "foo", DBI::SQL_CHAR()), 'bind in');
+ok($csr->execute, 'execute nvl');
+is($out, "FOO", 'expected FOO');
+
+ok($csr->bind_param(':in', ""), 'bind empty string');
+ok($csr->execute, 'execute empty string');
+is($out, "null", 'returned null string');
# --- test out buffer being too small
-ok(0, $csr = $dbh->prepare(q{
+ok($csr = $dbh->prepare(q{
begin
select rpad('foo',200) into :arg from dual;
- end;
-}), 1);
+ end;}), 'prepare test output buffer too small');
#$csr->trace(3);
undef $p1; # force buffer to be freed
-ok(0, $csr->bind_param_inout(':arg', \$p1, 20), 1);
+ok($csr->bind_param_inout(':arg', \$p1, 20), 'bind arg');
# Execute fails with:
# ORA-06502: PL/SQL: numeric or value error
# ORA-06512: at line 3 (DBD ERROR: OCIStmtExecute)
$tmp = $csr->execute;
#$tmp = undef if DBD::Oracle::ORA_OCI()>=8; # because BindByName given huge max len
-ok(0, !defined $tmp, 1);
+ok(!defined $tmp, 'output buffer too small');
# rebind with more space - and it should work
-ok(0, $csr->bind_param_inout(':arg', \$p1, 200), 1);
-ok(0, $csr->execute, 1);
-ok(0, length($p1) == 200, 0);
+ok($csr->bind_param_inout(':arg', \$p1, 200), 'rebind arg with more space');
+ok($csr->execute, 'execute rebind with more space');
+is(length($p1), 200, 'expected return length');
# --- test plsql_errstr function
@@ -218,20 +201,20 @@
# --- test dbms_output_* functions
$dbh->{PrintError} = 1;
-ok(0, $dbh->func(30000, 'dbms_output_enable'), 1);
+ok($dbh->func(30000, 'dbms_output_enable'), 'dbms_output_enable');
#$dbh->trace(3);
my @ary = ("foo", ("bar" x 15), "baz", "boo");
-ok(0, $dbh->func(@ary, 'dbms_output_put'), 1);
+ok($dbh->func(@ary, 'dbms_output_put'), 'dbms_output_put');
@ary = scalar $dbh->func('dbms_output_get'); # scalar context
-ok(0, @ary==1 && $ary[0] && $ary[0] eq 'foo', 0);
+ok(@ary==1 && $ary[0] && $ary[0] eq 'foo', 'dbms_output_get foo');
@ary = scalar $dbh->func('dbms_output_get'); # scalar context
-ok(0, @ary==1 && $ary[0] && $ary[0] eq 'bar' x 15, 0);
+ok(@ary==1 && $ary[0] && $ary[0] eq 'bar' x 15, 'dbms_output_get bar');
@ary = $dbh->func('dbms_output_get'); # list context
-ok(0, join(':',@ary) eq 'baz:boo', 0);
+is(join(':',@ary), 'baz:boo', 'dbms_output_get baz:boo');
$dbh->{PrintError} = 0;
#$dbh->trace(0);
@@ -248,38 +231,40 @@
my $parent = $dbh->prepare(qq{
BEGIN OPEN :cur1 FOR $cur_query; END;
});
- ok(0, $parent, $DBI::errstr);
- ok(0, $parent->bind_param(":p1", "V%"));
- ok(0, $parent->bind_param_inout(":cur1", \$cur1, 0, { ora_type => ORA_RSET } ));
- ok(0, $parent->execute());
+ ok($parent, 'prepare cursor');
+ ok($parent->bind_param(":p1", "V%"), 'bind p1');
+ ok($parent->bind_param_inout(
+ ":cur1", \$cur1, 0, { ora_type => ORA_RSET }), 'bind cursor');
+ ok($parent->execute(), 'execute for cursor');
my @r;
push @r, @tmp while @tmp = $cur1->fetchrow_array;
- ok(0, @r>0, "rows: ".@r);
+ ok(@r>0, "rows: ".@r);
#$dbh->trace(0); $parent->trace(0);
# compare results with normal execution of query
my $s1 = $dbh->selectall_arrayref($cur_query, undef, "V%");
my @s1 = map { @$_ } @$s1;
- ok(0, "@r" eq "@s1", "\nref=(@r),\nsql=(@s1)");
+ is("@r", "@s1", "ref = sql");
# --- test re-bind and re-execute of same 'parent' statement
my $cur1_str = "$cur1";
#$dbh->trace(4); $parent->trace(4);
- ok(0, $parent->bind_param(":p1", "U%"));
- ok(0, $parent->execute());
- ok(0, "$cur1" ne $cur1_str); # must be ref to new handle object
+ ok($parent->bind_param(":p1", "U%"), 'bind p1');
+ ok($parent->execute(), 'execute for cursor');
+ # must be ref to new handle object
+ isnt("$cur1", $cur1_str, 'expected ref to new handle');
@r = ();
push @r, @tmp while @tmp = $cur1->fetchrow_array;
#$dbh->trace(0); $parent->trace(0); $cur1->trace(0);
my $s2 = $dbh->selectall_arrayref($cur_query, undef, "U%");
my @s2 = map { @$_ } @$s2;
- ok(0, "@r" eq "@s2", "\nref=(@r),\nsql=(@s2)");
+ is("@r", "@s2", "ref = sql");
}
-print "test bind_param_inout of param that's not assigned to in executed statement\n";
+diag("test bind_param_inout of param that's not assigned to in executed statement\n");
# See http://www.mail-archive.com/[email protected]/msg18835.html
if (1) {
-my $sth = $dbh->prepare (q(
+ my $sth = $dbh->prepare (q(
BEGIN
-- :p1 := :p1 ;
-- :p2 := :p2 ;
@@ -287,28 +272,26 @@
:p1 := 'AAA' ;
:p2 := 'Z' ;
END IF ;
- END ;
-)) ;
-my ($p1, $p2, $p3) = ('Hello', 'Y', 'Y') ;
-$sth->bind_param_inout(':p1', \$p1, 30) ;
-$sth->bind_param_inout(':p2', \$p2, 1) ;
-$sth->bind_param_inout(':p3', \$p3, 1) ;
-print "Before p1=[$p1] p2=[$p2] p3=[$p3]\n" ;
-ok(0, $sth->execute);
-ok(0, $p1 eq 'Hello');
-ok(0, $p2 eq 'Y');
-ok(0, $p3 eq 'Y');
-print "After p1=[$p1] p2=[$p2] p3=[$p3]\n" ;
+ END ;));
+ my ($p1, $p2, $p3) = ('Hello', 'Y', 'Y') ;
+ $sth->bind_param_inout(':p1', \$p1, 30) ;
+ $sth->bind_param_inout(':p2', \$p2, 1) ;
+ $sth->bind_param_inout(':p3', \$p3, 1) ;
+ diag("Before p1=[$p1] p2=[$p2] p3=[$p3]\n");
+ ok($sth->execute, 'test bind_param_inout for non assigned');
+ is($p1, 'Hello', 'p1 ok');
+ is($p2, 'Y', 'p2 ok');
+ is($p3, 'Y', 'p3 ok');
+ diag("After p1=[$p1] p2=[$p2] p3=[$p3]\n");
}
SKIP: {
- sub skip { ok(0,1) for (1..$_[1]); print "$_[0]\n"; local $^W; last SKIP };
-
- print "test nvarchar2 arg passing to functions\n";
+ diag("test nvarchar2 arg passing to functions\n");
# http://www.nntp.perl.org/group/perl.dbi.users/24217
my $ora_server_version = $dbh->func("ora_server_version");
skip "Client/server version < 9.0", 15
if DBD::Oracle::ORA_OCI() < 9.0 || $ora_server_version->[0] < 9;
+
my $func_name = "dbd_oracle_nvctest".($ENV{DBD_ORACLE_SEQ}||'');
$dbh->do(qq{
CREATE OR REPLACE FUNCTION $func_name(arg nvarchar2, arg2 nvarchar2)
@@ -320,24 +303,26 @@
return 1;
end if;
END;
- }) or skip("Can't create a function ($DBI::errstr)", 15);
+ }) or skip "Can't create a function ($DBI::errstr)", 15;
my $sth = $dbh->prepare(qq{SELECT $func_name(?, ?) FROM DUAL}, {
# Oracle 8 describe fails with ORA-06553: PLS-561: charset mismatch
ora_check_sql => 0,
});
- ok(0, $sth, sprintf("Can't prepare select from function (%s)",$DBI::errstr||''));
- skip("Can't select from function ($DBI::errstr)", 14) unless $sth;
+ ok($sth, sprintf("Can't prepare select from function (%s)",$DBI::errstr||''));
+ skip "Can't select from function ($DBI::errstr)", 14 unless $sth;
for (1..2) {
- ok(0, $sth->bind_param(1, "foo", { ora_csform => SQLCS_NCHAR }));
- ok(0, $sth->bind_param(2, "bar", { ora_csform => SQLCS_NCHAR }));
- ok(0, $sth->execute());
- ok(0, my($returnVal) = $sth->fetchrow_array);
- ok(0, $returnVal eq "1");
+ ok($sth->bind_param(1, "foo", { ora_csform => SQLCS_NCHAR }),
+ 'bind foo');
+ ok($sth->bind_param(2, "bar", { ora_csform => SQLCS_NCHAR }),
+ 'bind bar');
+ ok($sth->execute(), 'execute');
+ ok(my($returnVal) = $sth->fetchrow_array, 'fetchrow returns value');
+ is($returnVal, "1", 'expected return value of 1');
}
- ok(0, $sth->execute("baz",undef));
- ok(0, my($returnVal) = $sth->fetchrow_array);
- ok(0, $returnVal eq "-1");
- ok(0, $dbh->do(qq{drop function $func_name}));
+ ok($sth->execute("baz",undef), 'execute with baz');
+ ok(my($returnVal) = $sth->fetchrow_array, 'fetchrow_returns value');
+ is($returnVal, "-1", 'expected -1 return');
+ ok($dbh->do(qq{drop function $func_name}), "drop $func_name");
}
@@ -348,13 +333,6 @@
# multiple params, mixed types and in only vs inout
-print "test ping\n";
-ok(0, $dbh->ping);
-$dbh->disconnect;
-ok(0, !$dbh->ping);
-
exit 0;
-BEGIN { $tests = 82 }
-# end.
__END__
Modified: dbd-oracle/trunk/t/30long.t
==============================================================================
--- dbd-oracle/trunk/t/30long.t (original)
+++ dbd-oracle/trunk/t/30long.t Wed Jul 23 07:19:48 2008
@@ -41,16 +41,16 @@
my $dbh = db_handle() or BAILOUT("Can't connect to database: $DBI::errstr");
my $ora_server_version = $dbh->func("ora_server_version");
-print "ora_server_version: @$ora_server_version\n";
+diag("ora_server_version: @$ora_server_version\n");
show_db_charsets($dbh) if $dbh;
foreach (@test_sets) {
my ($type_name, $type_num, $test_no_type) = @$_;
$use_utf8_data = use_utf8_data($dbh,$type_name);
- print qq(
+ diag( qq(
=========================================================================
Running long test for $type_name ($type_num) use_utf8_data=$use_utf8_data
-);
+));
run_long_tests($dbh, $type_name, $type_num);
run_long_tests($dbh, $type_name, 0) if $test_no_type;
}
@@ -77,12 +77,12 @@
return 0;
}
-sub run_long_tests
+sub run_long_tests
{
my ($dbh, $type_name, $type_num) = @_;
my ($sth);
my $append_len;
- SKIP:
+ SKIP:
{ #it all
# relationships between these lengths are important # e.g.
@@ -130,19 +130,19 @@
cols => long_test_cols( $type_name ),
rows => []
};
-
- skip "Unable to create test table for '$type_name' data ($DBI::err)." ,$tests_per_set
+
+ skip "Unable to create test table for '$type_name' data ($DBI::err)." ,$tests_per_set
if (!create_table($dbh, $tdata, 1));
# typically OCI 8 client talking to Oracle 7 database
- print "long_data[0] length $len_data0\n";
- print "long_data[1] length $len_data1\n";
- print "long_data[2] length $len_data2\n";
+ diag("long_data[0] length $len_data0\n");
+ diag("long_data[1] length $len_data1\n");
+ diag("long_data[2] length $len_data2\n");
- print " --- insert some $type_name data (ora_type $type_num)\n";
+ diag(" --- insert some $type_name data (ora_type $type_num)\n");
my $sqlstr = "insert into $table values (?, ?, SYSDATE)" ;
- ok( $sth = $dbh->prepare( $sqlstr ), "prepare: $sqlstr" );
+ ok( $sth = $dbh->prepare( $sqlstr ), "prepare: $sqlstr" );
my $bind_attr = { ora_type => $type_num };
# The explicit SQLCS_IMPLICIT is needed in some odd cases
$bind_attr->{ora_csform} = ($type_name =~ /^NCLOB/) ? SQLCS_NCHAR : SQLCS_IMPLICIT;
@@ -157,10 +157,10 @@
array_test($dbh);
- print " --- fetch $type_name data back again -- truncated - LongTruncOk == 1\n";
+ diag(" --- fetch $type_name data back again -- truncated - LongTruncOk == 1\n");
$dbh->{LongReadLen} = 20;
$dbh->{LongTruncOk} = 1;
- print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n";
+ diag("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");
# This behaviour isn't specified anywhere, sigh:
my $out_len = $dbh->{LongReadLen};
@@ -197,12 +197,12 @@
ok(!defined $tmp->[3][1], "last row undefined"); # NULL # known bug in DBD::Oracle <= 1.13
}
- print " --- fetch $type_name data back again -- truncated - LongTruncOk == 0\n";
+ diag(" --- fetch $type_name data back again -- truncated - LongTruncOk == 0\n");
$dbh->{LongReadLen} = $len_data1 - 10; # so $long_data[0] fits but long_data[1] doesn't
$dbh->{LongReadLen} = $dbh->{LongReadLen} / 2 if $type_name =~ /RAW/i;
my $LongReadLen = $dbh->{LongReadLen};
$dbh->{LongTruncOk} = 0;
- print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n";
+ diag("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");
$sqlstr = "select * from $table order by idx";
ok($sth = $dbh->prepare($sqlstr), "prepare $sqlstr" );
@@ -210,7 +210,7 @@
ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref $sqlstr" );
ok($tmp->[1] eq $long_data[0], "length tmp->[1] ".length($tmp->[1]) );
- {
+ {
local $sth->{PrintError} = 0;
ok(!defined $sth->fetchrow_arrayref,
"truncation error not triggered "
@@ -220,10 +220,10 @@
}
$sth->finish;
- print " --- fetch $type_name data back again -- complete - LongTruncOk == 0\n";
+ diag(" --- fetch $type_name data back again -- complete - LongTruncOk == 0\n");
$dbh->{LongReadLen} = $len_data1 +1000;
$dbh->{LongTruncOk} = 0;
- print "LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n";
+ diag("LongReadLen $dbh->{LongReadLen}, LongTruncOk $dbh->{LongTruncOk}\n");
$sqlstr = "select * from $table order by idx";
ok($sth = $dbh->prepare($sqlstr), "prepare: $sqlstr" );
@@ -242,7 +242,7 @@
if ($type_name =~ /LONG/i) ;
#$dbh->trace(4);
- print " --- fetch $type_name data back again -- via blob_read\n\n";
+ diag(" --- fetch $type_name data back again -- via blob_read\n\n");
$dbh->{LongReadLen} = 1024 * 90;
$dbh->{LongTruncOk} = 1;
@@ -251,11 +251,11 @@
ok($sth->execute, "execute $sqlstr" );
- print "fetch via fetchrow_arrayref\n";
+ diag("fetch via fetchrow_arrayref\n");
ok($tmp = $sth->fetchrow_arrayref, "fetchrow_arrayref 1: $sqlstr" );
cmp_ok_byte_nice($tmp->[1], $long_data[0], "truncated to LongReadLen $out_len");
- print "read via blob_read_all\n";
+ diag("read via blob_read_all\n");
cmp_ok(blob_read_all($sth, 1, \$p1, 4096) ,'==', length($long_data[0]),
"blob_read_all = length(\$long_data[0])" );
ok($p1 eq $long_data[0], cdif($p1, $long_data[0]) );
@@ -274,7 +274,7 @@
cmp_ok($len,'==', length($long_data[2]), "length of long_data[2] = $len" );
cmp_ok_byte_nice($p1, $long_data[2], "3rd row via blob_read_all");
- print "result is ".(utf8::is_utf8($p1) ? "UTF8" : "non-UTF8")."\n";
+ diag("result is ".(utf8::is_utf8($p1) ? "UTF8" : "non-UTF8")."\n");
if ($be_utf8) {
ok( utf8::is_utf8($p1), "result should be utf8");
}
@@ -288,7 +288,7 @@
skip( "ora_auto_lob tests for $type_name" ."s - not supported", 7+(13*3) )
if not ( $type_name =~ /LOB/i );
- print " --- testing ora_auto_lob to access $type_name LobLocator\n\n";
+ diag(" --- testing ora_auto_lob to access $type_name LobLocator\n\n");
my $data_fmt = "%03d foo!";
$sqlstr = qq{
@@ -300,29 +300,29 @@
ok($ll_sth->execute ,"execute $sqlstr" );
while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
- print "$idx: ".DBI::neat($lob_locator)."\n";
+ diag("$idx: ".DBI::neat($lob_locator)."\n");
last if !defined($lob_locator) && $idx == 43;
ok($lob_locator, '$lob_locator is true' );
is(ref $lob_locator , 'OCILobLocatorPtr', '$lob_locator is a OCILobLocatorPtr' );
ok( (ref $lob_locator and $$lob_locator), '$lob_locator deref ptr is true' ) ;
my $data = sprintf $data_fmt, $idx; #create a little data
- print "length of data to be written at offset 1: " .length($data) ."\n" ;
+ diag("length of data to be written at offset 1: " .length($data) ."\n" );
ok($dbh->func($lob_locator, 1, $data, 'ora_lob_write') ,"ora_lob_write" );
}
is($ll_sth->rows, 4);
- print " --- round again to check contents after $type_name write updates...\n";
+ diag(" --- round again to check contents after $type_name write updates...\n");
ok($ll_sth->execute,"execute (again 1) $sqlstr" );
while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
- print "$idx locator: ".DBI::neat($lob_locator)."\n";
+ diag("$idx locator: ".DBI::neat($lob_locator)."\n");
next if !defined($lob_locator) && $idx == 43;
- print "DBI::errstr=$DBI::errstr\n" if $DBI::err ;
+ diag("DBI::errstr=$DBI::errstr\n") if $DBI::err ;
my $content = $dbh->func($lob_locator, 1, 20, 'ora_lob_read');
- print "DBI::errstr=$DBI::errstr\n" if $DBI::err ;
+ diag("DBI::errstr=$DBI::errstr\n") if $DBI::err ;
ok($content,"content is true" );
- print "$idx content: ".nice_string($content)."\n"; #.DBI::neat($content)."\n";
+ diag("$idx content: ".nice_string($content)."\n"); #.DBI::neat($content)."\n";
cmp_ok(length($content) ,'==', 20 ,"lenth(content)" );
# but prefix has been overwritten:
@@ -354,10 +354,10 @@
} #while fetchrow
is($ll_sth->rows, 4);
- print " --- round again to check the $type_name length...\n";
+ diag(" --- round again to check the $type_name length...\n");
ok($ll_sth->execute ,"execute (again 2) $sqlstr" );
while (my ($lob_locator, $idx) = $ll_sth->fetchrow_array) {
- print "$idx locator: ".DBI::neat($lob_locator)."\n";
+ diag("$idx locator: ".DBI::neat($lob_locator)."\n");
next if !defined($lob_locator) && $idx == 43;
my $len = $dbh->func($lob_locator, 'ora_lob_length');
#lab: possible logic error here w/resp. to len
@@ -390,8 +390,8 @@
$a = [];
$sth->bind_param_inout(1,\$a, 2);
$sth->execute;
- print "a=$a\n";
- print "a=@$a\n";
+ diag("a=$a\n");
+ diag("a=@$a\n");
};
die "RETURNING array: $@";
}
@@ -401,13 +401,13 @@
{
my ($dbh,$len) = @_;
my $tsql = "select substr(lng,1,$len),idx from $table order by idx" ;
- print "-- prepare: $tsql\n" ;
+ diag("-- prepare: $tsql\n") ;
my $tsth = $dbh->prepare( $tsql );
$tsth->execute();
while ( my ( $d,$i ) = $tsth->fetchrow_array() )
{
last if not defined $d;
- print "$i: $d\n";
+ diag("$i: $d\n");
}
}
@@ -415,13 +415,13 @@
{
my ($dbh) = @_;
my $tsql = "select length(lng),idx from $table order by idx" ;
- print "-- prepare: $tsql\n" ;
+ diag("-- prepare: $tsql\n");
my $tsth = $dbh->prepare( $tsql );
$tsth->execute();
while ( my ( $l,$i ) = $tsth->fetchrow_array() )
{
last if not defined $l;
- print "$i: $l\n";
+ diag("$i: $l\n");
}
}
Modified: dbd-oracle/trunk/t/34pres_lobs.t
==============================================================================
--- dbd-oracle/trunk/t/34pres_lobs.t (original)
+++ dbd-oracle/trunk/t/34pres_lobs.t Wed Jul 23 07:19:48 2008
@@ -14,7 +14,7 @@
## By John Scoles, The Pythian Group
## ----------------------------------------------------------------------------
## Checks to see if the Interface for Persistent LOBs is working
-## Nothing fancy. Just an insert and a select if they fail this there is something up in OCI or the version
+## Nothing fancy. Just an insert and a select if they fail this there is something up in OCI or the version
## of oci being used
## ----------------------------------------------------------------------------
@@ -28,7 +28,7 @@
# create a database handle
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
-my $dbh = DBI->connect($dsn, $dbuser, '', { RaiseError=>1,
+my $dbh = DBI->connect($dsn, $dbuser, '', { RaiseError=>1,
AutoCommit=>1,
PrintError => 0 ,LongReadLen=>10000000});
# check that our db handle is good
@@ -36,7 +36,7 @@
SKIP: {
skip "OCI version less than 10.2\n Persistent LOBs Tests skiped.", 11 unless $ora_oci >= 10.2;
-
+
my $table = table();
@@ -45,11 +45,11 @@
ok($dbh->do(qq{
CREATE TABLE $table (
id NUMBER,
- clob1 CLOB,
- clob2 CLOB,
- blob1 BLOB,
+ clob1 CLOB,
+ clob2 CLOB,
+ blob1 BLOB,
blob2 BLOB)
- }));
+ }), 'create test table');
my $in_clob='ABCD' x 10_000;
@@ -59,50 +59,54 @@
$sql = "insert into ".$table."
(id,clob1,clob2, blob1,blob2)
values(?,?,?,?,?)";
-ok($sth=$dbh->prepare($sql ));
+ok($sth=$dbh->prepare($sql ), 'prepare for insert into lobs');
$sth->bind_param(1,3);
-ok($sth->bind_param(2,$in_clob,{ora_type=>SQLT_CHR}));
-ok($sth->bind_param(3,$in_clob,{ora_type=>SQLT_CHR}));
-ok($sth->bind_param(4,$in_blob,{ora_type=>SQLT_BIN}));
-ok($sth->bind_param(5,$in_blob,{ora_type=>SQLT_BIN}));
-ok($sth->execute());
+ok($sth->bind_param(2,$in_clob,{ora_type=>SQLT_CHR}), 'bind p2');
+ok($sth->bind_param(3,$in_clob,{ora_type=>SQLT_CHR}), 'bind p3');
+ok($sth->bind_param(4,$in_blob,{ora_type=>SQLT_BIN}), 'bind p4');
+ok($sth->bind_param(5,$in_blob,{ora_type=>SQLT_BIN}), 'bind p5');
+ok($sth->execute(), 'execute');
-ok($dbh->commit());
+ok($dbh->commit(), 'commit');
$sql='select * from '.$table;
-ok($sth=$dbh->prepare($sql,{ora_pers_lob=>1}));
+ok($sth=$dbh->prepare($sql,{ora_pers_lob=>1}), 'prepare with ora_pers_lob');
-ok($sth->execute());
+ok($sth->execute(), 'execute with ora_pers_lob');
my ($p_id,$log,$log2,$log3,$log4);
-ok(( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow());
+ok(( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow(),
+ 'fetcheow for ora_pers_lob');
-ok ($log eq $in_clob); #clob1 = in_clob
-ok ($log2 eq $in_clob); #clob2 = in_clob
-ok ($log3 eq $in_blob); #clob1 = in_clob
-ok ($log4 eq $in_blob); #clob2 = in_clob
-
-ok($sth=$dbh->prepare($sql,{ora_clbk_lob=>1,ora_piece_size=>.5*1024*1024}));
-
-ok($sth->execute());
-
-ok(( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow());
-ok ($log eq $in_clob); #clob1 = in_clob
-ok ($log2 eq $in_clob); #clob2 = in_clob
-ok ($log3 eq $in_blob); #clob1 = in_clob
-ok ($log4 eq $in_blob); #clob2 = in_clob
-
-ok($sth=$dbh->prepare($sql,{ora_piece_lob=>1,ora_piece_size=>.5*1024*1024}));
-
-ok($sth->execute());
-ok( ( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow());
-
-ok ($log eq $in_clob); #clob1 = in_clob
-ok ($log2 eq $in_clob); #clob2 = in_clob
-ok ($log3 eq $in_blob); #clob1 = in_clob
-ok ($log4 eq $in_blob); #clob2 = in_clob
+is ($log, $in_clob, 'clob1 = in_clob');
+is ($log2, $in_clob, 'clob2 = in_clob');
+is ($log3, $in_blob, 'clob1 = in_blob');
+is ($log4, $in_blob, 'clob2 = in_blob');
+
+ok($sth=$dbh->prepare($sql,{ora_clbk_lob=>1,ora_piece_size=>.5*1024*1024}),
+ 'prepare for ora_piece_size');
+
+ok($sth->execute(), 'execute for ora_piece_size');
+
+ok(( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow(), 'fetchrow');
+ok ($log eq $in_clob, 'clob1 = in_clob');
+ok ($log2 eq $in_clob, 'clob2 = in_clob');
+ok ($log3 eq $in_blob, 'clob1 = in_clob');
+ok ($log4 eq $in_blob, 'clob2 = in_clob');
+
+ok($sth=$dbh->prepare($sql,{ora_piece_lob=>1,ora_piece_size=>.5*1024*1024}),
+ 'prepare with ora_piece_lob/ora_piece_size');
+
+ok($sth->execute(), 'execute');
+ok( ( $p_id,$log,$log2,$log3,$log4 )=$sth->fetchrow(),
+ 'fetchrow');
+
+ok ($log eq $in_clob, 'clob1 = in_clob');
+ok ($log2 eq $in_clob, 'clob2 = in_clob');
+ok ($log3 eq $in_blob, 'clob1 = in_clob');
+ok ($log4 eq $in_blob, 'clob2 = in_clob');
#no neeed to look at the data is should be ok
Modified: dbd-oracle/trunk/t/40ph_type.t
==============================================================================
--- dbd-oracle/trunk/t/40ph_type.t (original)
+++ dbd-oracle/trunk/t/40ph_type.t Wed Jul 23 07:19:48 2008
@@ -1,17 +1,5 @@
#!perl -w
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
+use Test::More;
use strict;
use DBI qw(neat);
@@ -24,27 +12,6 @@
$| = 1;
$^W = 1;
-my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
-my $dsn = oracle_test_dsn();
-my $dbh = DBI->connect($dsn, $dbuser, '', {
- AutoCommit => 0,
- PrintError => 1,
- FetchHashKeyName => 'NAME_lc',
-});
-
-unless($dbh) {
- warn "Unable to connect to Oracle ($DBI::errstr)\nTests skipped.\n";
- print "1..0\n";
- exit 0;
-}
-
-eval {
- require Data::Dumper;
- $Data::Dumper::Useqq = $Data::Dumper::Useqq =1;
- $Data::Dumper::Terse = $Data::Dumper::Terse =1;
- $Data::Dumper::Indent= $Data::Dumper::Indent=1;
-};
-
# XXX ought to extend tests to check 'blank padded comparision semantics'
my @tests = (
# type: oracle internal type to use for placeholder values
@@ -61,7 +28,27 @@
$tests = 3;
$_->{SKIP} or $tests+=8 for @tests;
-print "1..$tests\n";
+my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
+my $dsn = oracle_test_dsn();
+my $dbh = DBI->connect($dsn, $dbuser, '', {
+ AutoCommit => 0,
+ PrintError => 1,
+ FetchHashKeyName => 'NAME_lc',
+});
+
+if ($dbh) {
+ plan tests => $tests;
+} else {
+ plan skip_all =>
+ "Unable to connect to Oracle ($DBI::errstr)\nTests skipped.\n";
+}
+
+eval {
+ require Data::Dumper;
+ $Data::Dumper::Useqq = $Data::Dumper::Useqq =1;
+ $Data::Dumper::Terse = $Data::Dumper::Terse =1;
+ $Data::Dumper::Indent= $Data::Dumper::Indent=1;
+};
my ($sth,$tmp);
my $table = "dbd_ora__drop_me" . ($ENV{DBD_ORACLE_SEQ}||'');
@@ -72,7 +59,7 @@
$dbh->do("DROP TABLE $table");
};
-ok(0, $dbh->do("CREATE TABLE $table (name VARCHAR2(2), vc VARCHAR2(20), c CHAR(20))"));
+ok($dbh->do("CREATE TABLE $table (name VARCHAR2(2), vc VARCHAR2(20), c CHAR(20))"), 'create test table');
my $val_with_trailing_space = "trailing ";
my $val_with_embedded_nul = "embedded\0nul";
@@ -82,67 +69,65 @@
my $ph_type = $test_info->{type} || die;
my $name = $test_info->{name} || die;
- print "#\n";
- print "# testing @{[ %$test_info ]} ...\n";
- print "#\n";
- if ($test_info->{SKIP}) {
- print "# skipping tests\n";
- foreach (1..12) { ok(0,1) }
- next;
- }
+ diag("\n");
+ diag("testing @{[ %$test_info ]} ...\n");
+ diag("\n");
+
+ SKIP: {
+ skip "skipping tests", 12 if ($test_info->{SKIP});
+
+ $dbh->{ora_ph_type} = $ph_type;
+ ok($dbh->{ora_ph_type} == $ph_type, 'set ora_ph_type');
+
+ $sth = $dbh->prepare("INSERT INTO $table(name,vc,c) VALUES (?,?,?)");
+ $sth->trace($test_info->{ti}) if $test_info->{ti};
+ $sth->execute("ts", $val_with_trailing_space, $val_with_trailing_space);
+ $sth->execute("en", $val_with_embedded_nul, $val_with_embedded_nul);
+ $sth->execute("es", '', ''); # empty string
+ $sth->trace(0) if $test_info->{ti};
- $dbh->{ora_ph_type} = $ph_type;
- ok(0, $dbh->{ora_ph_type} == $ph_type );
-
- $sth = $dbh->prepare("INSERT INTO $table(name,vc,c) VALUES (?,?,?)");
- $sth->trace($test_info->{ti}) if $test_info->{ti};
- $sth->execute("ts", $val_with_trailing_space, $val_with_trailing_space);
- $sth->execute("en", $val_with_embedded_nul, $val_with_embedded_nul);
- $sth->execute("es", '', ''); # empty string
- $sth->trace(0) if $test_info->{ti};
-
- $dbh->trace($test_info->{ts}) if $test_info->{ts};
- $tmp = $dbh->selectall_hashref(qq{
+ $dbh->trace($test_info->{ts}) if $test_info->{ts};
+ $tmp = $dbh->selectall_hashref(qq{
SELECT name, vc, length(vc) as len, nvl(vc,'ISNULL') as isnull, c
- FROM $table
- }, "name");
- ok(0, keys(%$tmp) == 3);
- $dbh->trace(0) if $test_info->{ts};
- $dbh->rollback;
-
- delete $_->{name} foreach values %$tmp;
- print Data::Dumper::Dumper($tmp);
-
- # check trailing_space behaviour
- my $expect = $val_with_trailing_space;
- $expect =~ s/\s+$// if $test_info->{chops_space};
- my $ok = ($tmp->{ts}->{vc} eq $expect);
- if (!$ok && $ph_type==1 && $name eq 'VARCHAR2') {
- warn " Placeholder behaviour for ora_type=1 VARCHAR2 (the default) varies with Oracle version.\n";
- warn " Oracle 7 didn't strip trailing spaces, Oracle 8 did, until 9.2.x\n";
- warn " Your system doesn't. If that seems odd, let us know.\n";
- $ok = 1;
- }
- ok(0, $ok, sprintf(" using ora_type %d expected %s but got %s for $name",
- $ph_type, neat($expect), neat($tmp->{ts}->{vc})) );
-
- # check embedded nul char behaviour
- $expect = $val_with_embedded_nul;
- $expect =~ s/\0.*// unless $test_info->{embed_nul};
- ok(0, $tmp->{en}->{vc} eq $expect, sprintf(" expected %s but got %s for $name",
+ FROM $table}, "name");
+ ok(keys(%$tmp) == 3, 'right keys');
+ $dbh->trace(0) if $test_info->{ts};
+ $dbh->rollback;
+
+ delete $_->{name} foreach values %$tmp;
+ diag(Data::Dumper::Dumper($tmp));
+
+ # check trailing_space behaviour
+ my $expect = $val_with_trailing_space;
+ $expect =~ s/\s+$// if $test_info->{chops_space};
+ my $ok = ($tmp->{ts}->{vc} eq $expect);
+ if (!$ok && $ph_type==1 && $name eq 'VARCHAR2') {
+ warn " Placeholder behaviour for ora_type=1 VARCHAR2 (the default) varies with Oracle version.\n";
+ warn " Oracle 7 didn't strip trailing spaces, Oracle 8 did, until 9.2.x\n";
+ warn " Your system doesn't. If that seems odd, let us know.\n";
+ $ok = 1;
+ }
+ ok($ok, sprintf(" using ora_type %d expected %s but got %s for $name",
+ $ph_type, neat($expect), neat($tmp->{ts}->{vc})) );
+
+ # check embedded nul char behaviour
+ $expect = $val_with_embedded_nul;
+ $expect =~ s/\0.*// unless $test_info->{embed_nul};
+ is($tmp->{en}->{vc}, $expect, sprintf(" expected %s but got %s for $name",
neat($expect),neat($tmp->{en}->{vc})) );
- # check empty string is NULL (irritating Oracle behaviour)
- ok(0, !defined $tmp->{es}->{vc});
- ok(0, !defined $tmp->{es}->{c});
- ok(0, !defined $tmp->{es}->{len});
- ok(0, $tmp->{es}->{isnull} eq 'ISNULL');
+ # check empty string is NULL (irritating Oracle behaviour)
+ ok(!defined $tmp->{es}->{vc}, 'vc defined');
+ ok(!defined $tmp->{es}->{c}, 'c defined');
+ ok(!defined $tmp->{es}->{len}, 'len defined');
+ is($tmp->{es}->{isnull}, 'ISNULL', 'ISNULL');
- exit 1 if $test_info->{ti} || $test_info->{ts};
+ exit 1 if $test_info->{ti} || $test_info->{ts};
+ }
}
-ok(0, $dbh->do("DROP TABLE $table"));
-ok(0, $dbh->disconnect );
+ok($dbh->do("DROP TABLE $table"), 'drop table');
+ok($dbh->disconnect, 'disconnect');
__END__
Modified: dbd-oracle/trunk/t/50cursor.t
==============================================================================
--- dbd-oracle/trunk/t/50cursor.t (original)
+++ dbd-oracle/trunk/t/50cursor.t Wed Jul 23 07:19:48 2008
@@ -1,19 +1,6 @@
#!perl -w
# From: Jeffrey Horn <[email protected]>
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
-
+use Test::More;
use DBI;
use DBD::Oracle qw(ORA_RSET);
use strict;
@@ -23,77 +10,76 @@
$| = 1;
+my ($limit, $tests);
+
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', { PrintError => 0 });
-unless ($dbh) {
- warn "Unable to connect to Oracle as $dbuser ($DBI::errstr)\nTests skipped.\n";
- print "1..0\n";
- exit 0;
-}
-
-# ORA-00900: invalid SQL statement
-# ORA-06553: PLS-213: package STANDARD not accessible
-my $tst = $dbh->prepare(q{declare foo char(50); begin RAISE INVALID_NUMBER; end;});
-if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) {
- warn "Your Oracle server doesn't support PL/SQL" if $dbh->err== 900;
- warn "Your Oracle PL/SQL is not properly installed" if $dbh->err==6553||$dbh->err==600;
- warn "Tests skipped\n";
- print "1..0\n";
- exit 0;
+if ($dbh) {
+ # ORA-00900: invalid SQL statement
+ # ORA-06553: PLS-213: package STANDARD not accessible
+ my $tst = $dbh->prepare(
+ q{declare foo char(50); begin RAISE INVALID_NUMBER; end;});
+ if ($dbh->err && ($dbh->err==900 || $dbh->err==6553 || $dbh->err==600)) {
+ warn "Your Oracle server doesn't support PL/SQL" if $dbh->err== 900;
+ warn "Your Oracle PL/SQL is not properly installed"
+ if $dbh->err==6553||$dbh->err==600;
+ plan skip_all => 'server does not support pl/sql or not installed';
+ }
+
+ $limit = $dbh->selectrow_array(
+ q{SELECT value-2 FROM v$parameter WHERE name = 'open_cursors'});
+ # allow for our open and close cursor 'cursors'
+ $limit -= 2 if $limit && $limit >= 2;
+ unless (defined $limit) { # v$parameter open_cursors could be 0 :)
+ warn("Can't determine open_cursors from v\$parameter, so using default\n");
+ $limit = 1;
+ }
+ $limit = 100 if $limit > 100; # lets not be greedy or upset DBA's
+ $tests = 2 + 10 * $limit;
+
+ plan tests => $tests;
+
+ diag("Max cursors: $limit\n");
+} else {
+ plan skip_all => "Unable to connect to Oracle as $dbuser ($DBI::errstr)\n";
}
-my $limit = $dbh->selectrow_array(q{
- SELECT value-2 FROM v$parameter WHERE name = 'open_cursors'
-});
-$limit -= 2 if $limit && $limit >= 2; # allow for our open and close cursor 'cursors'
-unless (defined $limit) { # v$parameter open_cursors could be 0 :)
- print "Can't determine open_cursors from v\$parameter, so using default\n";
- $limit = 1;
-}
-print "Max cursors: $limit\n";
-$limit = 100 if $limit > 100; # lets not be greedy or upset DBA's
-
-my $tests = 2 + 10 * $limit;
-
-print "1..$tests\n";
-
-
my @cursors;
my @row;
-print "opening cursors\n";
+diag("opening cursors\n");
my $open_cursor = $dbh->prepare( qq{
BEGIN OPEN :kursor FOR
SELECT * FROM all_objects WHERE rownum < 5;
END;
} );
-ok( 0, $open_cursor );
+ok($open_cursor, 'open cursor' );
foreach ( 1 .. $limit ) {
- print "opening cursor $_\n";
- ok( 0, $open_cursor->bind_param_inout( ":kursor", \my $cursor, 0, { ora_type => ORA_RSET } ) );
- ok( 0, $open_cursor->execute );
- ok( 0, !$open_cursor->{Active} );
-
- ok( 0, $cursor->{Active} );
- ok( 0, $cursor->fetchrow_arrayref);
- ok( 0, $cursor->fetchrow_arrayref);
- ok( 0, $cursor->finish ); # finish early
- ok( 0, !$cursor->{Active} );
+ diag("opening cursor $_\n");
+ ok( $open_cursor->bind_param_inout( ":kursor", \my $cursor, 0, { ora_type => ORA_RSET } ), 'open cursor bind param inout' );
+ ok( $open_cursor->execute, 'open cursor execute' );
+ ok(!$open_cursor->{Active}, 'open cursor Active');
+
+ ok($cursor->{Active}, 'cursor Active' );
+ ok($cursor->fetchrow_arrayref, 'cursor fetcharray');
+ ok($cursor->fetchrow_arrayref, 'cursor fetcharray');
+ ok($cursor->finish, 'cursor finish' ); # finish early
+ ok(!$cursor->{Active}, 'cursor not Active');
push @cursors, $cursor;
}
-print "closing cursors\n";
+diag("closing cursors\n");
my $close_cursor = $dbh->prepare( qq{ BEGIN CLOSE :kursor; END; } );
-ok(0, $close_cursor);
+ok($close_cursor, 'close cursor');
foreach ( 1 .. @cursors ) {
print "closing cursor $_\n";
my $cursor = $cursors[$_-1];
- ok(0, $close_cursor->bind_param( ":kursor", $cursor, { ora_type => ORA_RSET }));
- ok(0, $close_cursor->execute);
+ ok($close_cursor->bind_param( ":kursor", $cursor, { ora_type => ORA_RSET }), 'close cursor bind param');
+ ok($close_cursor->execute, 'close cursor execute');
}
$dbh->disconnect;
Modified: dbd-oracle/trunk/t/51scroll.t
==============================================================================
--- dbd-oracle/trunk/t/51scroll.t (original)
+++ dbd-oracle/trunk/t/51scroll.t Wed Jul 23 07:19:48 2008
@@ -13,7 +13,7 @@
## By John Scoles, The Pythian Group
## ----------------------------------------------------------------------------
## Just a few checks to see if one can use a scrolling cursor
-## Nothing fancy.
+## Nothing fancy.
## ----------------------------------------------------------------------------
BEGIN {
@@ -23,7 +23,7 @@
# create a database handle
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
-my $dbh = DBI->connect($dsn, $dbuser, '', { RaiseError=>1,
+my $dbh = DBI->connect($dsn, $dbuser, '', { RaiseError=>1,
AutoCommit=>1,
PrintError => 0 });
ok ($dbh->{RowCacheSize} = 10);
@@ -64,7 +64,7 @@
$value = $sth->ora_fetch_scroll(OCI_FETCH_CURRENT,0);
cmp_ok($value->[0], '==', 10, '... we should get the 10th record');
-
+
#now loop all the way back
for($i=1;$i<=9;$i++){
$value = $sth->ora_fetch_scroll(OCI_FETCH_PRIOR,0);
@@ -84,14 +84,14 @@
#now -3 records relative from the present position of 6;
$value = $sth->ora_fetch_scroll(OCI_FETCH_RELATIVE,-3);
-
+
cmp_ok($value->[0], '==', 4, '... we should get the 4th record');
#now get the 9th record from the start
$value = $sth->ora_fetch_scroll(OCI_FETCH_ABSOLUTE,9);
-
+
cmp_ok($value->[0], '==', 9, '... we should get the 9th record');
-
+
#now get the last record
$value = $sth->ora_fetch_scroll(OCI_FETCH_LAST,0);
Modified: dbd-oracle/trunk/t/55nested.t
==============================================================================
--- dbd-oracle/trunk/t/55nested.t (original)
+++ dbd-oracle/trunk/t/55nested.t Wed Jul 23 07:19:48 2008
@@ -1,17 +1,5 @@
#!perl -w
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
+use Test::More;
use DBI;
use DBD::Oracle qw(ORA_RSET);
@@ -26,44 +14,39 @@
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', { PrintError => 0 });
-unless ($dbh) {
- warn "Unable to connect to Oracle as $dbuser ($DBI::errstr)\nTests skipped.\n";
- print "1..0\n";
- exit 0;
+if ($dbh) {
+ plan tests=> 16;
+} else {
+ plan skip_all =>"Unable to connect to Oracle as $dbuser ($DBI::errstr)\n";
}
-my $tests = 16;
-
-print "1..$tests\n";
-
# ref cursors may be slow due to oracle bug 3735785
# believed fixed in
-# 9.2.0.6 (Server Patch Set)
-# 10.1.0.4 (Server Patch Set)
+# 9.2.0.6 (Server Patch Set)
+# 10.1.0.4 (Server Patch Set)
# 10.2.0.1 (Base Release)
-ok( 1,
- my $outer = $dbh->prepare(q{
+my $outer = $dbh->prepare(q{
SELECT object_name, CURSOR(SELECT object_name FROM dual)
- FROM all_objects WHERE rownum <= 5
- })
-);
-ok( 2, $outer->{ora_types}[1] == ORA_RSET);
-ok( 3, $outer->execute);
-ok( 4, my @row1 = $outer->fetchrow_array);
+ FROM all_objects WHERE rownum <= 5});
+ok($outer, 'prepare select');
+
+ok( $outer->{ora_types}[1] == ORA_RSET, 'set ORA_RSET');
+ok( $outer->execute, 'outer execute');
+ok( my @row1 = $outer->fetchrow_array, 'outer fetchrow');
my $inner1 = $row1[1];
-ok( 5, ref $inner1 eq 'DBI::st');
-ok( 6, $inner1->{Active});
-ok( 7, my @row1_1 = $inner1->fetchrow_array);
-ok( 8, $row1[0] eq $row1_1[0]);
-ok( 9, $inner1->{Active});
-ok(10, my @row2 = $outer->fetchrow_array);
-ok(11, !$inner1->{Active});
-ok(12, !$inner1->fetch);
-ok(13, $dbh->err == -1);
-ok(14, $dbh->errstr =~ / defunct /);
-ok(15, $outer->finish);
-ok(16, $dbh->{ActiveKids} == 0);
+is( ref $inner1, 'DBI::st', 'inner DBI::st');
+ok( $inner1->{Active}, 'inner Active');
+ok( my @row1_1 = $inner1->fetchrow_array, 'inner fetchrow_array');
+is( $row1[0], $row1_1[0], 'rows equal');
+ok( $inner1->{Active}, 'inner Active');
+ok(my @row2 = $outer->fetchrow_array, 'outer fetchrow_array');
+ok(!$inner1->{Active}, 'inner not Active');
+ok(!$inner1->fetch, 'inner fetch finished');
+is($dbh->err, -1, 'err = -1');
+like($dbh->errstr, qr/ defunct /, 'defunct');
+ok($outer->finish, 'outer finish');
+is($dbh->{ActiveKids}, 0, 'ActiveKids');
#########################################################################
@@ -78,7 +61,7 @@
my $tm_start = DBI::dbi_time();
$row_count++ while $rs->fetch;
my $elapsed = DBI::dbi_time() - $tm_start;
- print "Fetched $row_count rows ($caption): $elapsed secs.\n";
+ diag("Fetched $row_count rows ($caption): $elapsed secs.\n");
return $elapsed;
}
Modified: dbd-oracle/trunk/t/60reauth.t
==============================================================================
--- dbd-oracle/trunk/t/60reauth.t (original)
+++ dbd-oracle/trunk/t/60reauth.t Wed Jul 23 07:19:48 2008
@@ -1,17 +1,5 @@
#!perl -w
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
+use Test::More;
use DBI;
unshift @INC ,'t';
@@ -22,30 +10,28 @@
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbuser_2 = $ENV{ORACLE_USERID_2} || '';
-sub give_up { warn @_ if @_; print "1..0\n"; exit 0; }
-
if ($dbuser_2 eq '') {
- give_up("ORACLE_USERID_2 not defined. Tests skipped.\n");
+ plan skip_all => "ORACLE_USERID_2 not defined.\n";
}
# strip off @ on userid_2, as the reauth presumes current server
$dbuser_2 =~ s/@.*//;
(my $uid1 = uc $dbuser) =~ s:/.*::;
(my $uid2 = uc $dbuser_2) =~ s:/.*::;
if ($uid1 eq $uid2) {
- give_up("ORACLE_USERID_2 not unique.\nTests skipped.\n")
+ plan skip_all => "ORACLE_USERID_2 not unique.\n";
}
my $dsn = oracle_test_dsn();
my $dbh = DBI->connect($dsn, $dbuser, '');
-unless($dbh) {
- give_up("Unable to connect to Oracle ($DBI::errstr)\nTests skipped.\n");
+if ($dbh) {
+ plan tests => 3;
+} else {
+ plan skip_all => "Unable to connect to Oracle ($DBI::errstr)\n";
}
-print "1..3\n";
-
-ok(0, ($dbh->selectrow_array("SELECT USER FROM DUAL"))[0] eq $uid1 );
-ok(0, $dbh->func($dbuser_2, '', 'reauthenticate'));
-ok(0, ($dbh->selectrow_array("SELECT USER FROM DUAL"))[0] eq $uid2 );
+is(($dbh->selectrow_array("SELECT USER FROM DUAL"))[0], $uid1, 'uid1' );
+ok($dbh->func($dbuser_2, '', 'reauthenticate'), 'reauthenticate');
+is(($dbh->selectrow_array("SELECT USER FROM DUAL"))[0], $uid2, 'uid2' );
$dbh->disconnect;
Modified: dbd-oracle/trunk/t/70meta.t
==============================================================================
--- dbd-oracle/trunk/t/70meta.t (original)
+++ dbd-oracle/trunk/t/70meta.t Wed Jul 23 07:19:48 2008
@@ -1,17 +1,5 @@
#!perl -w
-
-sub ok ($$;$) {
- my($n, $ok, $warn) = @_;
- ++$t;
- die "sequence error, expected $n but actually $t"
- if $n and $n != $t;
- ($ok) ? print "ok $t\n"
- : print "# failed test $t at line ".(caller)[2]."\nnot ok $t\n";
- if (!$ok && $warn) {
- $warn = $DBI::errstr || "(DBI::errstr undefined)" if $warn eq '1';
- warn "$warn\n";
- }
-}
+use Test::More;
use strict;
use DBI qw(:sql_types);
@@ -26,23 +14,21 @@
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '', { PrintError => 0 });
-unless ($dbh) {
- warn "Unable to connect to Oracle as $dbuser ($DBI::errstr)\nTests skipped.\n";
- print "1..0\n";
- exit 0;
+if ($dbh) {
+ plan tests=>13;
+} else {
+ plan skip_all => "Unable to connect to Oracle as $dbuser ($DBI::errstr)\n";
}
-print "1..13\n";
-
-print "type_info_all\n";
+diag("type_info_all\n");
my @types = $dbh->type_info(SQL_ALL_TYPES);
-ok(0, @types >= 8);
-print Dumper( @types );
+ok(@types >= 8, 'more than 8 types');
+diag(Dumper( @types ));
-print "tables():\n";
+diag("tables():\n");
my @tables = $dbh->tables;
-print @tables." tables\n";
-ok(0, scalar @tables);
+diag(@tables." tables\n");
+ok(scalar @tables, 'tables');
my @table_info_params = (
[ 'schema list', undef, '%', undef, undef ],
@@ -52,21 +38,21 @@
foreach my $table_info_params (@table_info_params) {
my ($name) = shift @$table_info_params;
my $start = time;
- print "$name: table_info(".DBI::neat_list($table_info_params).")\n";
+ diag("$name: table_info(".DBI::neat_list($table_info_params).")\n");
my $table_info_sth = $dbh->table_info(@$table_info_params);
- ok(0, $table_info_sth);
+ ok($table_info_sth, 'table_info');
my $data = $table_info_sth->fetchall_arrayref;
- ok(0, $data);
- ok(0, scalar @$data);
+ ok($data, 'table_info fetch');
+ ok(scalar @$data, 'table_info data returned');
my $dur = time - $start;
- print "$name: ".@$data." rows, $dur seconds\n";
+ diag("$name: ".@$data." rows, $dur seconds\n");
# print Dumper($data);
}
my $sql_dbms_version = $dbh->get_info(18);
-ok(0,$sql_dbms_version);
-print "sql_dbms_version=$sql_dbms_version\n";
-ok(0,$sql_dbms_version =~ /^\d+\.\d+\.\d+$/);
+ok($sql_dbms_version, 'dbms_version');
+diag("sql_dbms_version=$sql_dbms_version\n");
+like($sql_dbms_version, qr/^\d+\.\d+\.\d+$/, 'matched');
$dbh->disconnect;
Modified: dbd-oracle/trunk/t/nchar_test_lib.pl
==============================================================================
--- dbd-oracle/trunk/t/nchar_test_lib.pl (original)
+++ dbd-oracle/trunk/t/nchar_test_lib.pl Wed Jul 23 07:19:48 2008
@@ -34,8 +34,24 @@
filehandle with an encoding, see open and perlfunc/binmode.
=cut
eval { binmode STDOUT, ':utf8' }; # Fails for perl 5.6
-print "Can't set binmode(STDOUT, ':utf8'): $@" if $@;
-
+diag("Can't set binmode(STDOUT, ':utf8'): $@") if $@;
+eval { binmode STDERR, ':utf8' }; # Fails for perl 5.6
+diag("Can't set binmode(STDERR, ':utf8'): $@") if $@;
+
+# Test::More duplicates STDOUT/STDERR at the start but does not copy the IO
+# layers from our STDOUT/STDERR. As a result any calls to Test::More::diag
+# with utf8 data will show warnings. Similarly, if we pass utf8 into
+# Test::More::pass, ok, etc etc. To get around this we specifically tell
+# Test::More to use our newly changed STDOUT and STDERR for failure_output
+# and output.
+my $tb = Test::More->builder;
+binmode($tb->failure_output, ':utf8');
+binmode($tb->output, ':utf8');
+
+# disable diag unless TEST_VERBOSE is set.
+if (!exists($ENV{TEST_VERBOSE})) {
+ $tb->no_diag(1);
+}
sub long_test_cols
{
my ($type) = @_ ;
@@ -172,8 +188,9 @@
my $v = $$recR[0];
my $byte_string = byte_string($v);
my $nice_string = nice_string($v);
- printf( "row: %3d: nice_string=%s byte_string=%s (%s, %s)\n",
- $cnt, $nice_string, $byte_string, $v, DBI::neat($v));
+ my $out = sprintf( "row: %3d: nice_string=%s byte_string=%s (%s, %s)\n",
+ $cnt, $nice_string, $byte_string, $v, DBI::neat($v));
+ diag($out);
}
return $cnt;
}
@@ -369,7 +386,7 @@
} else {
#$sql =~ s/ \( */(\n\t/g;
#$sql =~ s/, */,\n\t/g;
- print "$sql\n" ;
+ diag("$sql\n") ;
}
return $table;
# ok( not $dbh->err, "create table $table..." );
@@ -379,18 +396,20 @@
sub show_db_charsets
{
- my ( $dbh, $fh ) = @_;
- $fh ||= \*STDOUT;
+ my ( $dbh) = @_;
+ my $out;
my $ora_server_version = join ".", @{$dbh->func("ora_server_version")||[]};
my $paramsH = $dbh->ora_nls_parameters();
- printf $fh "Database $ora_server_version CHAR set is %s (%s), NCHAR set is %s (%s)\n",
+ $out = sprintf "Database $ora_server_version CHAR set is %s (%s), NCHAR set is %s (%s)\n",
$paramsH->{NLS_CHARACTERSET},
db_ochar_is_utf($dbh) ? "Unicode" : "Non-Unicode",
$paramsH->{NLS_NCHAR_CHARACTERSET},
db_nchar_is_utf($dbh) ? "Unicode" : "Non-Unicode";
+ diag($out);
my $ora_client_version = ORA_OCI();
- printf $fh "Client $ora_client_version NLS_LANG is '%s', NLS_NCHAR is '%s'\n",
+ $out = sprintf "Client $ora_client_version NLS_LANG is '%s', NLS_NCHAR is '%s'\n",
ora_env_var("NLS_LANG") || "<unset>", ora_env_var("NLS_NCHAR") || "<unset>";
+ diag($out);
}
sub db_ochar_is_utf { return shift->ora_can_unicode & 2 }
sub db_nchar_is_utf { return shift->ora_can_unicode & 1 }
@@ -424,9 +443,9 @@
# see comments in dbdimp.c for details.
DBD::Oracle::ora_cygwin_set_env('NLS_NCHAR', $ENV{NLS_NCHAR}||'')
if $^O eq 'cygwin';
- print defined ora_env_var("NLS_NCHAR") ? # defined?
+ diag(defined ora_env_var("NLS_NCHAR") ? # defined?
"set \$ENV{NLS_NCHAR}=$cset\n" :
- "set \$ENV{NLS_LANG}=undef\n" # XXX ?
+ "set \$ENV{NLS_LANG}=undef\n") # XXX ?
if defined $verbose;
}
@@ -435,10 +454,10 @@
my ($lang,$verbose) = @_;
if ( $lang ) {
$ENV{NLS_LANG} = "AMERICAN_AMERICA.$lang";
- print "set \$ENV{NLS_LANG}=AMERICAN_AMERICA.$lang\n" if ( $verbose );
+ diag("set \$ENV{NLS_LANG}=AMERICAN_AMERICA.$lang\n") if ( $verbose );
} else {
$ENV{NLS_LANG} = ""; # not the same as set_nls_nchar() above which uses undef
- print "set \$ENV{NLS_LANG}=''\n" if ( $verbose );
+ diag("set \$ENV{NLS_LANG}=''\n") if ( $verbose );
}
# Special treatment for environment variables under Cygwin -
# see comments in dbdimp.c for details.
lmpx.com only provides a reader for public news (NNTP) servers. It is not
affiliated with the servers or forums shown here and is not responsible for
the content of articles, which is written by their respective authors.