#!perl -w
## ----------------------------------------------------------------------------
## 31lob_extended.t
## By John Scoles, The Pythian Group
## ----------------------------------------------------------------------------
## This run through some bugs that have been found in earlier versions of DBD::Oracle
## Checks to ensure that these bugs no longer come up
## Basically this is testing the use of LOBs when returned via stored procedures with bind_param_inout
## ----------------------------------------------------------------------------
use Test::More;
use DBI;
use Config;
use DBD::Oracle qw(:ora_types);
use strict;
use warnings;
use Data::Dumper;
unshift @INC ,'t';
require 'nchar_test_lib.pl';
$| = 1;
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '',{
PrintError => 0,
});
if ($dbh) {
plan tests => 30;
$dbh->{LongReadLen} = 7000;
} else {
plan skip_all => "Unable to connect to Oracle";
diag('Test reported bugs');
}
my ($table, $data0, $data1) = setup_test($dbh);
my $PLSQL = <<"PLSQL";
BEGIN
OPEN ? FOR SELECT x FROM $table;
END;
PLSQL
$dbh->{RaiseError} = 1;
#
# bug in DBD::Oracle 1.21 where if ora_auto_lobs is not set and we attempt to
# fetch from a table containing lobs which has more than one row
# we get a segfault. This was due to prefetching more than one row.
#
{
my $testname = "ora_auto_lobs prefetch";
my ($sth1, $ev);
eval {$sth1 = $dbh->prepare($PLSQL, {ora_auto_lob => 0});};
ok(!$@, "$testname - prepare call proc");
my $sth2;
ok($sth1->bind_param_inout(1, \$sth2, 500, {ora_type => ORA_RSET}),
"$testname - bind out cursor");
ok($sth1->execute, "$testname - execute to get out cursor");
my ($lobl);
($lobl) = $sth2->fetchrow;
test_lob($dbh, $lobl, $testname, 6000, $data0);
($lobl) = $sth2->fetchrow;
test_lob($dbh, $lobl, $testname, 6000, $data1);
ok($sth2->finish, "$testname - finished returned sth");
ok($sth1->finish, "$testname - finished sth");
}
#
# prior to DBD::Oracle 1.22 if ora_auto_lob was set on a statement which
# was used to return a cursor on a result-set containing lobs, the lobs
# were not automatically fetched.
#
{
my $testname = "ora_auto_lobs not fetching";
my ($sth1, $ev, $lob);
# ora_auto_lobs is supposed to default to set
eval {$sth1 = $dbh->prepare($PLSQL);};
ok(!$@, "$testname prepare call proc");
my $sth2;
ok($sth1->bind_param_inout(1, \$sth2, 500, {ora_type => ORA_RSET}),
"$testname - bind out cursor");
ok($sth1->execute, "$testname - execute to get out cursor");
($lob) = $sth2->fetchrow;
ok($lob, "$testname - fetch returns something");
isnt(ref $lob, 'OCILobLocatorPtr', "$testname - not a lob locator");
is($lob, $data0, "$testname, first lob matches");
($lob) = $sth2->fetchrow;
ok($lob, "$testname - fetch returns something");
isnt(ref $lob, 'OCILobLocatorPtr', "$testname - not a lob locator");
is($lob, $data1, "$testname, second lob matches");
ok($sth2->finish, "$testname - finished returned sth");
ok($sth1->finish, "$testname - finished sth");
}
sub test_lob
{
my ($h, $lobl, $testname, $size, $data) = @_;
ok($lobl, "$testname - lob locator retrieved");
is(ref($lobl), 'OCILobLocatorPtr', "$testname - is a lob locator");
SKIP: {
skip "did not receive a lob locator", 4
unless ref($lobl) eq 'OCILobLocatorPtr';
my ($lob_length, $lob, $ev);
eval {$lob_length = $h->ora_lob_length($lobl);};
$ev = $@;
diag($ev) if $ev;
ok(!$ev, "$testname - first lob length $lob_length");
is($lob_length, $size, "$testname - correct lob length");
eval {$lob = $h->ora_lob_read($lobl, 1, $lob_length);};
$ev = $@;
diag($ev) if ($ev);
ok(!$ev, "$testname - read lob");
is($lob, $data, "$testname - lob returned matches lob inserted");
}
}
sub setup_test
{
my ($h) = @_;
my ($table, $sth, $ev);
eval {$table = create_table($h, {cols => [['x', 'clob']]}, 1)};
BAIL_OUT("test table not created- $@") if $@;
ok(!$ev, "created test table");
eval {
$sth = $h->prepare(qq/insert into $table (idx, x) values(?,?)/);
};
BAIL_OUT("Failed to prepare insert into $table - $@") if $@;
my $data0 = 'x' x 6000;
my $data1 = 'y' x 6000;
eval {
$sth->execute(1, $data0);
$sth->execute(2, $data1);
};
BAIL_OUT("Failed to insert test data into $table - $@") if $@;
ok(!$ev, "created test data");
return ($table, $data0, $data1);
}
END {
return unless $dbh;
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
eval {drop_table($dbh);};
if ($@) {
diag("table $table possibly not dropped - check - $@\n")
if $dbh->err ne '942';
}
}