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 c...@cam.ac.uk Tel: +44 1223 334506, Fax: +44 1223 334679
#!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;