Skip Menu |
 

Preferred bug tracker

Please visit the preferred bug tracker to report your issue.

This queue is for tickets about the DBD-Oracle CPAN distribution.

Report information
The Basics
Id: 46613
Status: resolved
Priority: 0/
Queue: DBD-Oracle

People
Owner: Nobody in particular
Requestors: tomas.zemres [...] gmail.com
Cc:
AdminCc:

Bug Information
Severity: (no value)
Broken in: 1.23
Fixed in:
  • 1.24
  • 1.24a
  • 1.24b



Subject: bugfix - sig-abort on nested objects with ora_objects=1
Download (untitled) / with headers
text/plain 142b
I found bug in ora_objects. I fixed this bug, patch is attached. I added also test for nested objects into t/58object.t (included in patch)
Subject: ora-nested-objects-svn-patch.diff
Index: oci8.c =================================================================== --- oci8.c (revision 12798) +++ oci8.c (working copy) @@ -1792,6 +1792,7 @@ fbh_obj_t *fld; OCIInd *obj_ind; fbh_obj_t *obj = base_obj; + OCIType *tdo = obj->tdo; if (DBIS->debug >= 5 || dbd_verbose >= 5 ) { PerlIO_printf(DBILOGFP, " getting attributes of object named %s with typecode=%s\n",obj->type_name,oci_typecode_name(obj->typecode)); @@ -1805,7 +1806,6 @@ OCIRef *type_ref=0; sword status; - OCIType *tdo; status = OCIObjectNew(fbh->imp_sth->envhp, fbh->imp_sth->errhp, fbh->imp_sth->svchp, OCI_TYPECODE_REF, (OCIType *)0, @@ -1816,7 +1816,7 @@ return 0; } - status=OCIObjectGetTypeRef(fbh->imp_sth->envhp,fbh->imp_sth->errhp, (dvoid*)fbh->obj->obj_value, type_ref); + status=OCIObjectGetTypeRef(fbh->imp_sth->envhp,fbh->imp_sth->errhp, (dvoid*)value, type_ref); if (status != OCI_SUCCESS) { oci_error(sth, fbh->imp_sth->errhp, status, "OCIObjectGetTypeRef"); return 0; @@ -1837,7 +1837,7 @@ if (tdo != obj->tdo) { /* new subtyped -> get obj description */ if (DBIS->debug >= 5 || dbd_verbose >= 5 ) { - PerlIO_printf(DBILOGFP, " describe subtype of object type %s\n",base_obj->type_name); + PerlIO_printf(DBILOGFP, " describe subtype (tdo=%x) of object type %s (tdo=%x)\n",(int)tdo,base_obj->type_name,(int)base_obj->tdo); } Newz(1, obj->next_subtype, 1, fbh_obj_t); @@ -1907,7 +1907,7 @@ } status = OCIObjectGetAttr(fbh->imp_sth->envhp, fbh->imp_sth->errhp, value, - obj_ind, obj->tdo, + obj_ind, tdo, (CONST oratext**)&fld->type_name, &fld->type_namel, 1, (ub4 *)0, 0, &attr_null_status, &attr_null_struct, &attr_value, &attr_tdo); @@ -1929,7 +1929,7 @@ get_object (sth,fld->fields[0].value, fbh, &fld->fields[0],attr_value); av_push(list, new_ora_object(fld->fields[0].value, fld->typecode)); - } else{ /* else, display the scaler type attribute */ + } else{ /* else, display the scalar type attribute */ get_attr_val(sth,list, fbh, fld->type_name, fld->typecode, attr_value); Index: t/58object.t =================================================================== --- t/58object.t (revision 12798) +++ t/58object.t (working copy) @@ -5,7 +5,7 @@ use strict; use Data::Dumper; -use Test::More tests => 35; +use Test::More tests => 46; unshift @INC ,'t'; require 'nchar_test_lib.pl'; @@ -45,10 +45,12 @@ my $obj_prefix = "dbd_test_"; my $super_type = "${obj_prefix}_type_A"; my $sub_type = "${obj_prefix}_type_B"; +my $complex_type = "${obj_prefix}_type_C"; my $table = "${obj_prefix}_obj_table"; sub drop_test_objects { - for my $obj ("TABLE $table", "TYPE $sub_type", "TYPE $super_type") { + for my $obj ("TABLE $table", "TYPE $sub_type", "TYPE $super_type", + "TYPE $complex_type") { #do not warn if already there eval { local $dbh->{PrintError} = 0; @@ -68,6 +70,10 @@ datetime DATE, amount NUMERIC(10,5) ) NOT FINAL }) or die $dbh->errstr; +$dbh->do(qq{ CREATE OR REPLACE TYPE $complex_type AS OBJECT ( + obj1 $super_type, + obj2 $super_type + )}) 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')) }) @@ -152,6 +158,31 @@ is_deeply($obj->attr, $expected_hash, 'DBD::Oracle::Object->attr'); is($obj->attr("NAME"), 'obj3', 'DBD::Oracle::Object->attr("NAME")'); +# Test nested objects +$sth = $dbh->prepare("select new $complex_type($super_type(1, 'AB'), $sub_type(2,'X', TO_DATE('2009-06-01', 'YYYY-MM-DD'), 3.3)) FROM dual"); +ok ($sth, 'nested objects: Prepare select'); +ok ($sth->execute(), 'nested objects: Execute select'); + +@row1 = $sth->fetchrow(); +is (scalar @row1, 1, 'nested objects: 1 column fetched'); + +$obj = $row1[0]; +isa_ok($obj, 'DBD::Oracle::Object', 'nested objects: complex_object ISA ok'); +is($obj->type_name, uc "$schema.$complex_type", 'nested objects: complex_object type ok'); + +isa_ok($obj->attr('OBJ1'), 'DBD::Oracle::Object', 'nested objects: complex_object->obj1 ISA ok'); +isa_ok($obj->attr('OBJ2'), 'DBD::Oracle::Object', 'nested objects: complex_object->obj2 ISA ok'); + +is($obj->attr('OBJ1')->type_name, uc "$schema.$super_type", 'nested objects: complex_object->obj1->type_name ok'); +is($obj->attr('OBJ2')->type_name, uc "$schema.$sub_type", 'nested objects: complex_object->obj2->type_name ok'); + +is_deeply([$obj->attr('OBJ1')->attributes], ['NUM', 1, 'NAME', 'AB'], + 'nested objects: complex_object->obj1->attributes ok'); +is_deeply([$obj->attr('OBJ2')->attributes], ['NUM', 2, 'NAME', 'X', 'DATETIME', '2009-06-01T00:00:00', 'AMOUNT', 3.3], + 'nested objects: complex_object->obj2->attributes ok'); + +$sth->finish(); + #cleanup &drop_test_objects; $dbh->disconnect;
Note: this bug is only in 1.23 (not in 1.22)
I am sorry, I posted bad file - this is final patch file
Index: oci8.c =================================================================== --- oci8.c (revision 12798) +++ oci8.c (working copy) @@ -1776,7 +1776,7 @@ /*gets the properties of an object from a fetch by using the attributes saved in the describe */ int -get_object (SV *sth, AV *list, imp_fbh_t *fbh,fbh_obj_t *base_obj,OCIComplexObject *value){ +get_object (SV *sth, AV *list, imp_fbh_t *fbh,fbh_obj_t *base_obj,OCIComplexObject *value, OCIType *instance_tdo){ dTHX; sword status; @@ -1792,6 +1792,7 @@ fbh_obj_t *fld; OCIInd *obj_ind; fbh_obj_t *obj = base_obj; + OCIType *tdo = instance_tdo ? instance_tdo : obj->tdo; if (DBIS->debug >= 5 || dbd_verbose >= 5 ) { PerlIO_printf(DBILOGFP, " getting attributes of object named %s with typecode=%s\n",obj->type_name,oci_typecode_name(obj->typecode)); @@ -1805,30 +1806,31 @@ OCIRef *type_ref=0; sword status; - OCIType *tdo; - status = OCIObjectNew(fbh->imp_sth->envhp, fbh->imp_sth->errhp, fbh->imp_sth->svchp, - OCI_TYPECODE_REF, (OCIType *)0, - (dvoid *)0, OCI_DURATION_DEFAULT, TRUE, - (dvoid **) &type_ref); - if (status != OCI_SUCCESS) { - oci_error(sth, fbh->imp_sth->errhp, status, "OCIObjectNew"); - return 0; + if (!instance_tdo) { + status = OCIObjectNew(fbh->imp_sth->envhp, fbh->imp_sth->errhp, fbh->imp_sth->svchp, + OCI_TYPECODE_REF, (OCIType *)0, + (dvoid *)0, OCI_DURATION_DEFAULT, TRUE, + (dvoid **) &type_ref); + if (status != OCI_SUCCESS) { + oci_error(sth, fbh->imp_sth->errhp, status, "OCIObjectNew"); + return 0; + } + + status=OCIObjectGetTypeRef(fbh->imp_sth->envhp,fbh->imp_sth->errhp, (dvoid*)value, type_ref); + if (status != OCI_SUCCESS) { + oci_error(sth, fbh->imp_sth->errhp, status, "OCIObjectGetTypeRef"); + return 0; + } + + OCITypeByRef_log_stat(fbh->imp_sth->envhp,fbh->imp_sth->errhp,type_ref,&tdo,status); + + if (status != OCI_SUCCESS) { + oci_error(sth, fbh->imp_sth->errhp, status, "OCITypeByRef"); + return 0; + } } - status=OCIObjectGetTypeRef(fbh->imp_sth->envhp,fbh->imp_sth->errhp, (dvoid*)fbh->obj->obj_value, type_ref); - if (status != OCI_SUCCESS) { - oci_error(sth, fbh->imp_sth->errhp, status, "OCIObjectGetTypeRef"); - return 0; - } - - OCITypeByRef_log_stat(fbh->imp_sth->envhp,fbh->imp_sth->errhp,type_ref,&tdo,status); - - if (status != OCI_SUCCESS) { - oci_error(sth, fbh->imp_sth->errhp, status, "OCITypeByRef"); - return 0; - } - if (tdo != obj->tdo) { /* this is subtype -> search for subtype obj */ while (obj->next_subtype && tdo != obj->tdo) { @@ -1837,7 +1839,7 @@ if (tdo != obj->tdo) { /* new subtyped -> get obj description */ if (DBIS->debug >= 5 || dbd_verbose >= 5 ) { - PerlIO_printf(DBILOGFP, " describe subtype of object type %s\n",base_obj->type_name); + PerlIO_printf(DBILOGFP, " describe subtype (tdo=%x) of object type %s (tdo=%x)\n",(int)tdo,base_obj->type_name,(int)base_obj->tdo); } Newz(1, obj->next_subtype, 1, fbh_obj_t); @@ -1907,7 +1909,7 @@ } status = OCIObjectGetAttr(fbh->imp_sth->envhp, fbh->imp_sth->errhp, value, - obj_ind, obj->tdo, + obj_ind, tdo, (CONST oratext**)&fld->type_name, &fld->type_namel, 1, (ub4 *)0, 0, &attr_null_status, &attr_null_struct, &attr_value, &attr_tdo); @@ -1926,10 +1928,10 @@ if (fld->typecode != OCI_TYPECODE_OBJECT) attr_value = *(dvoid **)attr_value; - get_object (sth,fld->fields[0].value, fbh, &fld->fields[0],attr_value); + get_object (sth,fld->fields[0].value, fbh, &fld->fields[0],attr_value, attr_tdo); av_push(list, new_ora_object(fld->fields[0].value, fld->typecode)); - } else{ /* else, display the scaler type attribute */ + } else{ /* else, display the scalar type attribute */ get_attr_val(sth,list, fbh, fld->type_name, fld->typecode, attr_value); @@ -1967,7 +1969,7 @@ } else { if (obj->element_typecode == OCI_TYPECODE_OBJECT || obj->element_typecode == OCI_TYPECODE_VARRAY || obj->element_typecode== OCI_TYPECODE_TABLE || obj->element_typecode== OCI_TYPECODE_NAMEDCOLLECTION){ fld->value = newAV(); - get_object (sth,fld->value, fbh, fld,element); + get_object (sth,fld->value, fbh, fld,element, 0); av_push(list, new_ora_object(fld->value, obj->element_typecode)); } else{ /* else, display the scaler type attribute */ get_attr_val(sth,list, fbh, obj->type_name, obj->element_typecode, element); @@ -2018,7 +2020,7 @@ fbh->obj->value=newAV(); /*will return referance to an array of scalars*/ - if (!get_object(sth,fbh->obj->value,fbh,fbh->obj,fbh->obj->obj_value)){ + if (!get_object(sth,fbh->obj->value,fbh,fbh->obj,fbh->obj->obj_value, 0)){ return 0; } else { sv_setsv(dest_sv, sv_2mortal(new_ora_object(fbh->obj->value, fbh->obj->typecode))); Index: t/58object.t =================================================================== --- t/58object.t (revision 12798) +++ t/58object.t (working copy) @@ -5,7 +5,7 @@ use strict; use Data::Dumper; -use Test::More tests => 35; +use Test::More tests => 46; unshift @INC ,'t'; require 'nchar_test_lib.pl'; @@ -45,10 +45,12 @@ my $obj_prefix = "dbd_test_"; my $super_type = "${obj_prefix}_type_A"; my $sub_type = "${obj_prefix}_type_B"; +my $complex_type = "${obj_prefix}_type_C"; my $table = "${obj_prefix}_obj_table"; sub drop_test_objects { - for my $obj ("TABLE $table", "TYPE $sub_type", "TYPE $super_type") { + for my $obj ("TABLE $table", "TYPE $sub_type", "TYPE $super_type", + "TYPE $complex_type") { #do not warn if already there eval { local $dbh->{PrintError} = 0; @@ -68,6 +70,10 @@ datetime DATE, amount NUMERIC(10,5) ) NOT FINAL }) or die $dbh->errstr; +$dbh->do(qq{ CREATE OR REPLACE TYPE $complex_type AS OBJECT ( + obj1 $super_type, + obj2 $super_type + )}) 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')) }) @@ -152,6 +158,31 @@ is_deeply($obj->attr, $expected_hash, 'DBD::Oracle::Object->attr'); is($obj->attr("NAME"), 'obj3', 'DBD::Oracle::Object->attr("NAME")'); +# Test nested objects +$sth = $dbh->prepare("select new $complex_type($super_type(1, 'AB'), $sub_type(2,'X', TO_DATE('2009-06-01', 'YYYY-MM-DD'), 3.3)) FROM dual"); +ok ($sth, 'nested objects: Prepare select'); +ok ($sth->execute(), 'nested objects: Execute select'); + +@row1 = $sth->fetchrow(); +is (scalar @row1, 1, 'nested objects: 1 column fetched'); + +$obj = $row1[0]; +isa_ok($obj, 'DBD::Oracle::Object', 'nested objects: complex_object ISA ok'); +is($obj->type_name, uc "$schema.$complex_type", 'nested objects: complex_object type ok'); + +isa_ok($obj->attr('OBJ1'), 'DBD::Oracle::Object', 'nested objects: complex_object->obj1 ISA ok'); +isa_ok($obj->attr('OBJ2'), 'DBD::Oracle::Object', 'nested objects: complex_object->obj2 ISA ok'); + +is($obj->attr('OBJ1')->type_name, uc "$schema.$super_type", 'nested objects: complex_object->obj1->type_name ok'); +is($obj->attr('OBJ2')->type_name, uc "$schema.$sub_type", 'nested objects: complex_object->obj2->type_name ok'); + +is_deeply([$obj->attr('OBJ1')->attributes], ['NUM', 1, 'NAME', 'AB'], + 'nested objects: complex_object->obj1->attributes ok'); +is_deeply([$obj->attr('OBJ2')->attributes], ['NUM', 2, 'NAME', 'X', 'DATETIME', '2009-06-01T00:00:00', 'AMOUNT', 3.3], + 'nested objects: complex_object->obj2->attributes ok'); + +$sth->finish(); + #cleanup &drop_test_objects; $dbh->disconnect;
Download (untitled) / with headers
text/plain 175b
I am having trouble applying the patch as I think trunk has moved along little since you made the diff can you apply the patch to the attached OCI8.c file and 58object.t
Download 58object.t
text/x-perl 5.3k
#!perl -w use DBI; use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR); use strict; use Data::Dumper; use Test::More tests => 35; 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"; sub drop_test_objects { for my $obj ("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; # 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"); 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")'); #cleanup &drop_test_objects; $dbh->disconnect; 1;
Download oci8.c
text/x-csrc 124.8k

Message body is not shown because it is too large.

Subject: Re: [rt.cpan.org #46613] bugfix - sig-abort on nested objects with ora_objects=1
Date: Wed, 17 Jun 2009 14:11:31 +0200
To: bug-DBD-Oracle [...] rt.cpan.org
From: Tomas Pokorny <tnt [...] netsafe.cz>
Download (untitled) / with headers
text/plain 101b
There is also another problem with type-inheritance, but I don't know what is wrong now. TomasP
Download (untitled) / with headers
text/plain 329b
Tomas I do not think it is a bug in the DBD code ME thinks the test you were atempting is invalid. Can you rewrite you test so it selects from a table rather from dual. Seems if you do it from dual it only will return a string and cannot dig deeper. I tried it with another table and it seems to work ok cheers John Show quoted text
>
Shouold be fixed in 1.24


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.