Re: DBD-Oracle 1.24a reports ORA-24334 in t/58object.t

[email protected] (Charles Jardine)
Newsgroups perl.dbi.users
Message-ID <[email protected]> 
On 21/04/10 18:56, Everett, Timothy S wrote:
> Thank you for the patch.  This fixed the ORA-24334 problem.

Thank you very much for testing the patch. I will try to ensure that
a similar fix gets into the next release of DBD::Oracle.

> The test suite now runs to completion.  FYI it still complains about one
> subtest in 58object.t.

I would be very grateful if you could help me get to the bottom of this
problem as well. I have attached a modified version of t/58object.t.
Could you possibly run this and send the output to me. (It will
be tracing at level 9 - I don't think we need to bother the list
with the output.)

-- 
Charles Jardine - Computing Service, University of Cambridge
[email protected]    Tel: +44 1223 334506, Fax: +44 1223 334679
58object.t (text/troff, 8.1 KB) 
#!perl -w

use DBI;
use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
use strict;
use Data::Dumper;

DBI->trace(9);

use Test::More tests => 51;
unshift @INC ,'t';
require 'nchar_test_lib.pl';

$| = 1;

BEGIN {
	use_ok('DBI');
}

$ENV{NLS_DATE_FORMAT} = 'YYYY-MM-DD"T"HH24:MI:SS';

# create a database handle
my $dsn = oracle_test_dsn();
my $dbuser = $ENV{ORACLE_USERID} || 'scott/tiger';
my $dbh = DBI->connect($dsn, $dbuser, '',{ RaiseError=>1, 
					AutoCommit=>1,
					PrintError => 0,
					 ora_objects => 1 });

my ($schema) = $dbuser =~ m{^([^/]*)};

# Test ora_objects flag 
cmp_ok($dbh->{ora_objects}, 'eq', '1', 'ora_objects flag is set to 1');

$dbh->{ora_objects} = 0;
cmp_ok($dbh->{ora_objects}, 'eq', '0', 'ora_objects flag is set to 0');

# check that our db handle is good
isa_ok($dbh, "DBI::db");


ok( $schema = $dbh->selectrow_array(
  "select sys_context('userenv', 'current_schema') from dual"
), 'Fetch current schema name');
 

my $obj_prefix = "dbd_test_";
my $super_type = "${obj_prefix}_type_A";
my $sub_type = "${obj_prefix}_type_B";
my $table = "${obj_prefix}_obj_table";
my $outer_type = "${obj_prefix}_outer_type";
my $inner_type = "${obj_prefix}_inner_type";
my $list_type = "${obj_prefix}_list_type";
my $nest_table = "${obj_prefix}_nest_table";
my $list_table = "${obj_prefix}_list_table";

sub drop_test_objects {
    for my $obj ("TABLE $list_table", "TABLE $nest_table",
                 "TYPE $list_type", "TYPE $outer_type", "TYPE $inner_type",
                 "TABLE $table", "TYPE $sub_type", "TYPE $super_type") {
        #do not warn if already there
        eval {
            local $dbh->{PrintError} = 0;
            $dbh->do(qq{drop $obj});
        };
    }
}

&drop_test_objects;

$dbh->do(qq{ CREATE OR REPLACE TYPE $super_type AS OBJECT (
                num     INTEGER,
                name    VARCHAR2(20)
            ) NOT FINAL }) or die $dbh->errstr;

$dbh->do(qq{ CREATE OR REPLACE TYPE $sub_type UNDER $super_type (
                datetime  DATE,
                amount    NUMERIC(10,5)
            ) NOT FINAL }) or die $dbh->errstr;
$dbh->do(qq{ CREATE TABLE $table (id INTEGER, obj $super_type) })
            or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $table VALUES (1, $super_type(13, 'obj1')) })
            or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $table VALUES (2, $sub_type(NULL, 'obj2', 
                    TO_DATE('2004-11-30 14:27:18', 'YYYY-MM-DD HH24:MI:SS'),
                    12345.6789)) }
            ) or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $table VALUES (3, $sub_type(5, 'obj3', NULL, 777.666)) }
            ) or die $dbh->errstr;

$dbh->do(qq{ CREATE OR REPLACE TYPE $inner_type AS OBJECT (
                num     INTEGER,
                name    VARCHAR2(20)
            ) FINAL }) or die $dbh->errstr;
$dbh->do(qq{ CREATE OR REPLACE TYPE $outer_type AS OBJECT (
                num     INTEGER,
                obj     $inner_type
            ) FINAL }) or die $dbh->errstr;
$dbh->do(qq{ CREATE OR REPLACE TYPE $list_type AS
                            TABLE OF $inner_type }) or die $dbh->errstr;
$dbh->do(qq{ CREATE TABLE $nest_table(obj $outer_type) }) or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $nest_table VALUES($outer_type(91, $inner_type(1, 'one'))) }
            ) or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $nest_table VALUES($outer_type(92, $inner_type(0, null))) }
            ) or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $nest_table VALUES($outer_type(93, null)) }
            ) or die $dbh->errstr;

$dbh->do(qq{ CREATE TABLE $list_table ( id INTEGER, list $list_type )
               NESTED TABLE list STORE AS ${list_table}_list }) or die $dbh->errstr;
$dbh->do(qq{ INSERT INTO $list_table VALUES(81,$list_type($inner_type(null, 'listed'))) }
            ) or die $dbh->errstr;


# Test old (backward compatible) interface 

# test select testing objects 
my $sth = $dbh->prepare("select * from $table order by id");
ok ($sth, 'old: Prepare select');
ok ($sth->execute(), 'old: Execute select');

my @row1 = $sth->fetchrow();
ok (scalar @row1, 'old: Fetch first row');
cmp_ok(ref $row1[1], 'eq', 'ARRAY', 'old: Row 1 column 2 is an ARRAY');
cmp_ok(scalar(@{$row1[1]}), '==', 2, 'old: Row 1 column 2 is has 2 elements');

my @row2 = $sth->fetchrow();
ok (scalar @row2, 'old: Fetch second row');
cmp_ok(ref $row2[1], 'eq', 'ARRAY', 'old: Row 2 column 2 is an ARRAY');
cmp_ok(scalar(@{$row2[1]}), '==', 2, 'old: Row 2 column 2 is has 2 elements');

my @row3 = $sth->fetchrow();
ok (scalar @row3, 'old: Fetch third row');
cmp_ok(ref $row3[1], 'eq', 'ARRAY', 'old: Row 3 column 2 is an ARRAY');
cmp_ok(scalar(@{$row3[1]}), '==', 2, 'old: Row 3 column 2 is has 2 elements');

ok (!$sth->fetchrow(), 'old: No more rows expected');

#print STDERR Dumper(\@row1, \@row2, \@row3);

# Test new (extended) object interface 

# enable extended object support 
$dbh->{ora_objects} = 1;

# test select testing objects - in extended mode 
$sth = $dbh->prepare("select * from $table order by id");
ok ($sth, 'new: Prepare select');
ok ($sth->execute(), 'new: Execute select');


@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row');
cmp_ok(ref $row1[1], 'eq', 'DBD::Oracle::Object', 'new: Row 1 column 2 is an DBD:Oracle::Object');
cmp_ok(uc $row1[1]->type_name, "eq", uc "$schema.$super_type", "new: Row 1 column 2 object type");
is_deeply([$row1[1]->attributes], ['NUM', 13, 'NAME', 'obj1'], "new: Row 1 column 2 object attributes");

@row2 = $sth->fetchrow();
ok (scalar @row2, 'new: Fetch second row');
cmp_ok(ref $row2[1], 'eq', 'DBD::Oracle::Object', 'new: Row 2 column 2 is an DBD::Oracle::Object');
cmp_ok(uc $row2[1]->type_name, "eq", uc "$schema.$sub_type", "new: Row 2 column 2 object type");
print Dumper($row2[1]);
is_deeply([$row2[1]->attributes], ['NUM', undef, 'NAME', 'obj2', 
            'DATETIME', '2004-11-30T14:27:18', 'AMOUNT', '12345.6789'], "new: Row 1 column 2 object attributes");

@row3 = $sth->fetchrow();
ok (scalar @row3, 'new: Fetch third row');
cmp_ok(ref $row3[1], 'eq', 'DBD::Oracle::Object', 'new: Row 3 column 2 is an DBD::Oracle::Object');
cmp_ok(uc $row3[1]->type_name, "eq", uc "$schema.$sub_type", "new: Row 3 column 2 object type");
is_deeply([$row3[1]->attributes], ['NUM', 5, 'NAME', 'obj3', 
            'DATETIME', undef, 'AMOUNT', '777.666'], "new: Row 1 column 2 object attributes");

ok (!$sth->fetchrow(), 'new: No more rows expected');

#print STDERR Dumper(\@row1, \@row2, \@row3);

# Test DBD::Oracle::Object 
my $obj = $row3[1];
my $expected_hash = {
        NUM         => 5,
        NAME        => 'obj3',
        DATETIME    => undef,
        AMOUNT      => 777.666,
    };
is_deeply($obj->attr_hash, $expected_hash, 'DBD::Oracle::Object->attr_hash');
is_deeply($obj->attr, $expected_hash, 'DBD::Oracle::Object->attr');
is($obj->attr("NAME"), 'obj3', 'DBD::Oracle::Object->attr("NAME")');

# try the list table
$sth = $dbh->prepare("select * from $list_table");
ok ($sth, 'new: Prepare select with nested table of objects');
ok ($sth->execute(), 'new: Execute (nested table)');

@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row (nested table)');
is_deeply($row1[1]->[0]->attr, {NUM=>undef, NAME=>'listed'},
           'Check propertes of first (and only) item in nested table');

ok (!$sth->fetchrow(), 'new: No more rows expected (nested table)');

#try the nested table
$sth = $dbh->prepare("select * from $nest_table");
ok ($sth, 'new: Prepare select with nested object');
ok ($sth->execute(), 'new: Execute (nested object)');

@row1 = $sth->fetchrow();
ok (scalar @row1, 'new: Fetch first row (nested object)');
is($row1[0]->attr->{NUM}, '91', 'Check obj.num');
is_deeply($row1[0]->attr->{OBJ}->attr, {NUM=>'1', NAME=>'one'}, 'Check obj.obj');

@row2 = $sth->fetchrow();
ok (scalar @row2, 'new: Fetch second row (nested object)');
is($row2[0]->attr->{NUM}, '92', 'Check obj.num');
is_deeply($row2[0]->attr->{OBJ}->attr, {NUM=>'0', NAME=>undef}, 'Check obj.obj');

@row3 = $sth->fetchrow();
ok (scalar @row3, 'new: Fetch third row (nested object)');
is_deeply($row3[0]->attr, {NUM=>'93', OBJ=>undef}, 'Check obj');

ok (!$sth->fetchrow(), 'new: No more rows expected (nested object)');

#print STDERR Dumper(\@row1, \@row2, \@row3);


#cleanup 
&drop_test_objects;
$dbh->disconnect;

1;
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.