Author: byterock
Date: Wed Jan 14 07:28:59 2009
New Revision: 12438
Added:
dbd-oracle/trunk/Object.pm
dbd-oracle/trunk/t/58object.t
Modified:
dbd-oracle/trunk/Changes
dbd-oracle/trunk/Oracle.pm
dbd-oracle/trunk/dbdimp.c
dbd-oracle/trunk/dbdimp.h
dbd-oracle/trunk/oci8.c
dbd-oracle/trunk/ocitrace.h
Log:
Added rt.cpan.org Ticket #=42328 ora_objects attribute for extended embedded
objects support from tnt at netsafe.cz
Fix for rt.cpan.org Ticket #=42328 user defined types from different schema
in describe_obj from tnt at netsafe.cz
Modified: dbd-oracle/trunk/Changes
==============================================================================
--- dbd-oracle/trunk/Changes (original)
+++ dbd-oracle/trunk/Changes Wed Jan 14 07:28:59 2009
@@ -1,4 +1,6 @@
=head1 Changes in DBD-Oracle 1.23(svn rev #####)
+ Added rt.cpan.org Ticket #=42328 ora_objects attribute for extended embedded
objects support from tnt at netsafe.cz
+ Fix for rt.cpan.org Ticket #=42328 user defined types from different schema
in describe_obj from tnt at netsafe.cz
Added a README for sun suggested by Jim McCullars
Clean up of white space and formating to 4 tabs from John Scoles
Fix for GCC 4.3 warnings from Eric Simon
Added: dbd-oracle/trunk/Object.pm
==============================================================================
--- (empty file)
+++ dbd-oracle/trunk/Object.pm Wed Jan 14 07:28:59 2009
@@ -0,0 +1,24 @@
+package DBD::Oracle::Object;
+
+use strict;
+use warnings;
+
+sub type_name { shift->{type_name} }
+
+sub attributes { @{shift->{attributes}} }
+
+sub attr_hash {
+ my $self = shift;
+ return $self->{attr_hash} ||= { $self->attributes };
+}
+
+sub attr {
+ my $self = shift;
+ if (@_) {
+ my $key = shift;
+ return $self->attr_hash->{$key};
+ }
+ return $self->attr_hash;
+}
+
+1;
\ No newline at end of file
Modified: dbd-oracle/trunk/Oracle.pm
==============================================================================
--- dbd-oracle/trunk/Oracle.pm (original)
+++ dbd-oracle/trunk/Oracle.pm Wed Jan 14 07:28:59 2009
@@ -17,6 +17,8 @@
use DBI ();
use DynaLoader ();
use Exporter ();
+ use Object;
+
@ISA = qw(DynaLoader Exporter);
%EXPORT_TAGS = (
ora_types => [ qw(
@@ -319,7 +321,8 @@
ora_ncharset => undef,
ora_session_mode => undef,
ora_verbose => undef,
- ora_oci_success_warn => undef
+ ora_oci_success_warn => undef,
+ ora_objects => undef
};
}
@@ -1519,6 +1522,24 @@
$dbh->{ora_oci_success_warn} =1;
+=item ora_objects
+
+Use this value to enable extended embedded oracle objects mode. In extended:
+
+=over 8
+
+=item 1
+
+Embedded objects are returned as <DBD::Oracle::Object> instance (including
type-name etc.) instead of simple ARRAY.
+
+=item 2
+
+Determine object type for each instance. All object attributes are returned
(not only super-type's attributes).
+
+=back
+
+ $dbh->{ora_objects} = 1;
+
=item ora_ph_type
The default placeholder data type for the database session.
Modified: dbd-oracle/trunk/dbdimp.c
==============================================================================
--- dbd-oracle/trunk/dbdimp.c (original)
+++ dbd-oracle/trunk/dbdimp.c Wed Jan 14 07:28:59 2009
@@ -43,6 +43,8 @@
int is_extproc = 0;
int dbd_verbose = 0; /* DBD only debugging*/
int oci_warn = 0; /* show oci warnings */
+int ora_objects = 0; /* get oracle embedded objects as instance of
DBD::Oracle::Object */
+
/* bitflag constants for figuring out how to handle utf8 for array binds */
#define ARRAY_BIND_NATIVE 0x01
#define ARRAY_BIND_UTF8 0x02
@@ -103,7 +105,7 @@
if (*(SvEND(errstr)-1) == '\n')
--SvCUR(errstr);
}
-
+
if (what || status != OCI_ERROR) {
sv_catpv(errstr, (debug<0) ? " (" : " (DBD ");
sv_catpv(errstr, oci_status_name(status));
@@ -379,7 +381,8 @@
DBD_ATTRIB_GET_IV( attr, "ora_verbose", 11, svp, dbd_verbose);
if (DBD_ATTRIB_TRUE(attr,"ora_oci_success_warn",20,svp))
DBD_ATTRIB_GET_IV( attr, "ora_oci_success_warn", 20, svp,
oci_warn);
-
+ if (DBD_ATTRIB_TRUE(attr,"ora_objects",11,svp))
+ DBD_ATTRIB_GET_IV( attr, "ora_objects",11, svp, ora_objects);
/* dbi_imp_data code adapted from DBD::mysql */
if (DBIc_has(imp_dbh, DBIcf_IMPSET)) {
@@ -954,6 +957,9 @@
if (kl==20 && strEQ(key, "ora_oci_success_warn") ) {
oci_warn = SvIV (valuesv);
}
+ else if (kl==11 && strEQ(key, "ora_objects")) {
+ ora_objects = SvIV (valuesv);
+ }
else if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key,
"dbd_verbose"))) {
dbd_verbose = SvIV (valuesv);
}
@@ -989,7 +995,7 @@
if (cacheit) /* cache value for later DBI 'quick' fetch? */
(void)hv_store((HV*)SvRV(dbh), key, kl, newSVsv(valuesv), 0);
-
+
return TRUE;
}
@@ -1009,6 +1015,9 @@
if (kl==20 && strEQ(key, "ora_oci_success_warn")) {
retsv = newSViv (oci_warn);
}
+ else if (kl==11 && strEQ(key, "ora_objects")) {
+ retsv = newSViv (ora_objects);
+ }
else if (kl==11 && (strEQ(key, "ora_verbose") || strEQ(key,
"dbd_verbose"))) {
retsv = newSViv (dbd_verbose);
}
@@ -1230,28 +1239,28 @@
dest = start+strlen(start);
style = "?";
- }
+ }
else if (isDIGIT(*src)) { /* ':1' */
idx = atoi(src);
*dest++ = 'p'; /* ':1'->':p1' */
if (idx <= 0)
croak("Placeholder :%d invalid, placeholders
must be >= 1", idx);
-
+
while(isDIGIT(*src))
*dest++ = *src++;
style = ":1";
- }
+ }
else if (isALNUM(*src)) { /* ':foo' */
while(isALNUM(*src)) /* includes '_' */
*dest++ = toLOWER(*src), src++;
style = ":foo";
-
+
} else { /* perhaps ':=' PL/SQL
construct */
/* if (src == ':') *dest++ = *src++; XXX? move past
'::'? */
continue;
}
-
+
*dest = '\0'; /* handy for debugging */
namelen = (dest-start);
if (laststyle && style != laststyle)
@@ -2450,7 +2459,7 @@
}
return 1;
-
+
}
static int
@@ -3849,7 +3858,7 @@
while(--i >= 0)
av_store(av, i, newSVpv((char*)imp_sth->fbh[i].name,0));
- }
+ }
else if (kl==11 && strEQ(key, "ParamValues")) {
HV *pvhv = newHV();
if (imp_sth->all_params_hv) {
@@ -3865,55 +3874,55 @@
retsv = newRV_noinc((SV*)pvhv);
cacheit = FALSE;
- }
+ }
else if (kl==11 && strEQ(key, "ora_lengths")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i, newSViv((IV)imp_sth->fbh[i].disize));
- }
+ }
else if (kl==9 && strEQ(key, "ora_types")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i, newSViv(imp_sth->fbh[i].dbtype));
- }
+ }
else if (kl==4 && strEQ(key, "TYPE")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i,
newSViv(ora2sql_type(imp_sth->fbh+i).dbtype));
- }
+ }
else if (kl==5 && strEQ(key, "SCALE")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i,
newSViv(ora2sql_type(imp_sth->fbh+i).scale));
- }
+ }
else if (kl==9 && strEQ(key, "PRECISION")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i,
newSViv(ora2sql_type(imp_sth->fbh+i).prec));
#ifdef XXX
- }
+ }
else if (kl==9 && strEQ(key, "ora_rowid")) {
/* return current _binary_ ROWID (oratype 11) uncached */
/* Use { ora_type => 11 } when binding to a placeholder */
retsv = newSVpv((char*)&imp_sth->cda->rid,
sizeof(imp_sth->cda->rid));
cacheit = FALSE;
#endif
- }
+ }
else if (kl==17 && strEQ(key, "ora_est_row_width")) {
retsv = newSViv(imp_sth->est_width);
cacheit = TRUE;
- }
+ }
else if (kl==8 && strEQ(key, "NULLABLE")) {
AV *av = newAV();
retsv = newRV(sv_2mortal((SV*)av));
while(--i >= 0)
av_store(av, i, boolSV(imp_sth->fbh[i].nullok));
- }
+ }
else {
return Nullsv;
}
Modified: dbd-oracle/trunk/dbdimp.h
==============================================================================
--- dbd-oracle/trunk/dbdimp.h (original)
+++ dbd-oracle/trunk/dbdimp.h Wed Jan 14 07:28:59 2009
@@ -152,7 +152,10 @@
OCIType *obj_type; /*if an embeded
object this is the OCIType returned by a OCIObjectPin*/
fbh_obj_t *fields; /*one object
for each field/property*/
int field_count; /*The number of
fields Not really needed but nice to have*/
+ fbh_obj_t *next_subtype; /*There is strored
information about subtypes for inteherited objects*/
AV *value; /*The
value to send back to Perl This way there are no memory leaks*/
+ SV *full_type_name; /*Perl value of
full type name = schema_name "." type_name*/
+
};
struct imp_fbh_st { /* field buffer EXPERIMENTAL */
@@ -251,6 +254,7 @@
extern int ora_fetchtest;
extern int dbd_verbose;
extern int oci_warn;
+extern int ora_objects;
extern ub2 charsetid;
extern ub2 ncharsetid;
Modified: dbd-oracle/trunk/oci8.c
==============================================================================
--- dbd-oracle/trunk/oci8.c (original)
+++ dbd-oracle/trunk/oci8.c Wed Jan 14 07:28:59 2009
@@ -19,6 +19,9 @@
DBISTATE_DECLARE;
+int describe_obj_by_tdo(SV *sth,imp_sth_t *imp_sth,fbh_obj_t *obj,int level );
+int dump_struct(imp_sth_t *imp_sth,fbh_obj_t *obj,int level);
+
void
@@ -567,11 +570,10 @@
DBD_ATTRIB_GET_IV( attribs, "ora_prefetch_memory", 19, svp,
imp_sth->prefetch_memory);
DBD_ATTRIB_GET_IV( attribs, "ora_verbose", 11, svp,
dbd_verbose);
DBD_ATTRIB_GET_IV( attribs, "ora_oci_success_warn", 20, svp,
oci_warn);
+ DBD_ATTRIB_GET_IV( attribs, "ora_objects", 11, svp,
ora_objects);
- if (!dbd_verbose)
- DBD_ATTRIB_GET_IV( attribs, "dbd_verbose",
11, svp, dbd_verbose);
-
-
+ if (!dbd_verbose)
+ DBD_ATTRIB_GET_IV( attribs, "dbd_verbose", 11, svp,
dbd_verbose);
}
@@ -656,7 +658,7 @@
AV *av;
SV **sv_p;
if( bindp ){ /* For GCC not to warn on unused parameter*/ }
-
+
tuples_av = phs->imp_sth->bind_tuples;
if(tuples_av) {
/* NOTE: we already checked the validity in
ora_st_bind_for_array_exec(). */
@@ -668,7 +670,7 @@
*bufpp = SvPV(sv, phs_len);
phs->alen = (phs->alen_incnull) ? phs_len+1 : phs_len;
phs->indp = 0;
- }
+ }
else {
*bufpp = SvPVX(sv);
phs->alen = 0;
@@ -765,7 +767,7 @@
*bufpp = phs->desc_h;
phs->alen = 0;
- }
+ }
else {
SV *sv = phs->sv;
@@ -1007,15 +1009,15 @@
imp_sth_nested->errhp = imp_sth->errhp;
imp_sth_nested->srvhp = imp_sth->srvhp;
imp_sth_nested->svchp = imp_sth->svchp;
-
+
imp_sth_nested->stmhp = stmhp_nested;
imp_sth_nested->nested_cursor = 1;
imp_sth_nested->rs_array_on = 1;
imp_sth_nested->stmt_type = OCI_STMT_SELECT;
-
+
DBIc_IMPSET_on(imp_sth_nested);
DBIc_ACTIVE_on(imp_sth_nested); /* So describe won't do an
execute */
-
+
if (!dbd_describe(dest_sv, imp_sth_nested))
return 0;
}
@@ -1090,7 +1092,7 @@
if (SvOK(phs->sv)) { /* ie a number, convert to string ASAP
*/
if (!(SvROK(phs->sv) && phs->is_inout))
sv_2pv(phs->sv, &na);
- }
+ }
else { /* ensure we're at least an SVt_PV (so SvPVX etc work)
*/
if(SvUPGRADE(phs->sv, SVt_PV)){} /* For GCC not to warn
on unused result */
}
@@ -1122,7 +1124,7 @@
ub4 amtp;
if(SvUPGRADE(phs->sv, SVt_PV)){/* For GCC not to warn on unused
result */}; /* just in case */
-
+
amtp = SvCUR(phs->sv); /* XXX UTF8? */
/* Create a temp lob for non-empty string */
@@ -1754,10 +1756,27 @@
}
}
+
+SV* new_ora_object (AV* list, OCITypeCode typecode) {
+ dTHX;
+ SV* objref = newRV_noinc((SV*) list);
+
+ if (ora_objects && typecode == OCI_TYPECODE_OBJECT) {
+ HV* self = newHV();
+ (void)hv_store(self, "type_name", 9, av_shift(list), 0);
+ (void)hv_store(self, "attributes", 10, objref, 0);
+ objref = newRV_noinc((SV*) self);
+ objref = sv_bless(objref, gv_stashpv("DBD::Oracle::Object", 0));
+
+ }
+ return objref;
+}
+
/*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 *obj,OCIComplexObject
*value){
+get_object (SV *sth, AV *list, imp_fbh_t *fbh,fbh_obj_t
*base_obj,OCIComplexObject *value){
+
dTHX;
sword status;
dvoid *element ;
@@ -1771,6 +1790,7 @@
OCIIter *itr;
fbh_obj_t *fld;
OCIInd *obj_ind;
+ fbh_obj_t *obj = base_obj;
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));
@@ -1780,12 +1800,72 @@
case OCI_TYPECODE_OBJECT :
/* embedded ADT */
+ if (ora_objects){
+
+ 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;
+ }
+
+
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) {
+ obj = obj->next_subtype;
+ }
+ 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);
+ }
+
+ Newz(1, obj->next_subtype, 1,
fbh_obj_t);
+ obj->next_subtype->tdo = tdo;
+ if ( describe_obj_by_tdo(sth,
fbh->imp_sth, obj->next_subtype, 0 /*unknown level there*/) ) {
+ obj = obj->next_subtype;
+ if (DBIS->debug >= 5 ||
dbd_verbose >= 5 ){
+
dump_struct(fbh->imp_sth,obj,0);
+ }
+ }
+ else {
+ obj->next_subtype = 0;
+ }
+ }
+
+ if (DBIS->debug >= 5 || dbd_verbose >=
5 ) {
+ PerlIO_printf(DBILOGFP, "
getting attributes of object subtype %s\n",obj->type_name);
+ }
+ }
+
+ av_push(list, newSVpv((char*)obj->type_name,
obj->type_namel));
+ }
+
if (obj->obj_ind) {
obj_ind = obj->obj_ind;
} else {
status=OCIObjectGetInd(fbh->imp_sth->envhp,fbh->imp_sth->errhp,value,(dvoid**)&obj_ind);
-
+
if (status != OCI_SUCCESS) {
oci_error(sth, fbh->imp_sth->errhp,
status, "OCIObjectGetInd");
return 0;
@@ -1793,7 +1873,13 @@
}
for (pos = 0; pos < obj->field_count; pos++){
- fld = &obj->fields[pos]; /*get the field */
+
+ fld = &obj->fields[pos]; /*get the field */
+
+ if (ora_objects) {
+ /* add field name */
+ av_push(list,
newSVpv((char*)fld->type_name, fld->type_namel));
+ }
status=OCIObjectGetInd(fbh->imp_sth->envhp,fbh->imp_sth->errhp,value,(dvoid**)&obj->obj_ind);
/*
@@ -1837,8 +1923,9 @@
fld->fields[0].value = newAV();
if (fld->typecode !=
OCI_TYPECODE_OBJECT)
attr_value = *(dvoid
**)attr_value;
+
get_object
(sth,fld->fields[0].value, fbh, &fld->fields[0],attr_value);
- av_push(list, newRV_noinc((SV
*) fld->fields[0].value));
+ av_push(list,
new_ora_object(fld->fields[0].value, fld->typecode));
} else{ /* else, display the scaler
type attribute */
@@ -1872,14 +1959,14 @@
(dvoid **) &element,
(dvoid **) &element_null, &eoc)
&& !eoc;)
{
-
+
if
(*element_null==OCI_IND_NULL){
av_push(list,
&sv_undef);
} 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);
- av_push(list,
newRV_noinc((SV *) fld->value));
+ get_object
(sth,fld->value, fbh, fld,element);
+ 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);
}
@@ -1932,7 +2019,7 @@
if (!get_object(sth,fbh->obj->value,fbh,fbh->obj,fbh->obj->obj_value)){
return 0;
} else {
- sv_setsv(dest_sv, sv_2mortal(newRV_noinc((SV *)
fbh->obj->value)));
+ sv_setsv(dest_sv, sv_2mortal(new_ora_object(fbh->obj->value,
fbh->obj->typecode)));
return 1;
}
@@ -2080,18 +2167,22 @@
case OCI_TYPECODE_OBJECT : /* embedded ADT
*/
+ if (obj->next_subtype) {
+ empty_oci_object(obj->next_subtype);
+ }
+
for (pos = 0; pos < obj->field_count; pos++){
- fld = &obj->fields[pos]; /*get the field */
- if (fld->typecode == OCI_TYPECODE_OBJECT ||
fld->typecode == OCI_TYPECODE_VARRAY || fld->typecode == OCI_TYPECODE_TABLE ||
fld->typecode == OCI_TYPECODE_NAMEDCOLLECTION){
- empty_oci_object(fld);
- if (fld->value && SvTYPE(fld->value) ==
SVt_PVAV){
- av_clear(fld->value);
- av_undef(fld->value);
- }
+ fld = &obj->fields[pos]; /*get the
field */
+ if (fld->typecode ==
OCI_TYPECODE_OBJECT || fld->typecode == OCI_TYPECODE_VARRAY || fld->typecode ==
OCI_TYPECODE_TABLE || fld->typecode == OCI_TYPECODE_NAMEDCOLLECTION){
+ empty_oci_object(fld);
+ if (fld->value &&
SvTYPE(fld->value) == SVt_PVAV){
+ av_clear(fld->value);
+ av_undef(fld->value);
+ }
- } else {
- return 1;
- }
+ } else {
+ return 1;
+ }
}
break;
@@ -2160,10 +2251,10 @@
if (imp_sth->rs_array_on!=1 ||
imp_sth->rs_array_size<1 ||
imp_sth->rs_array_size>128){
-
+
imp_sth->rs_array_on=0;
imp_sth->rs_array_size=1;
-
+
}
imp_sth->rs_array_num_rows=0;
imp_sth->rs_array_idx=0;
@@ -2194,7 +2285,7 @@
/* number of rows to cache if using oraperl */
if (SvOK(imp_drh->ora_cache_o)){
imp_sth->cache_rows = SvIV(imp_drh->ora_cache_o);
- }
+ }
else if (SvOK(imp_drh->ora_cache)){
imp_sth->cache_rows = SvIV(imp_drh->ora_cache);
}
@@ -2271,41 +2362,49 @@
{
dTHX;
sword status;
+ OCIRef *type_ref;
if (DBIS->debug >= 5 || dbd_verbose >= 5 ) {
PerlIO_printf(DBILOGFP, "At level=%d in description an embedded
object \n",level);
}
/*Describe the field (OCIParm) we know it is a object or a collection */
- OCIAttrGet_parmdp(imp_sth,parm, &obj->type_name, &obj->type_namel,
OCI_ATTR_TYPE_NAME, status);
- /*get its name and hence TDO*/
- /*Now get the Actual TDO */
+ /* Get the Actual TDO */
+ OCIAttrGet_parmdp(imp_sth,parm, &type_ref, 0, OCI_ATTR_REF_TDO, status);
if (status != OCI_SUCCESS) {
- oci_error(sth,imp_sth->errhp, status, "OCIAttrGet");
+ oci_error(sth, imp_sth->errhp, status, "OCIAttrGet");
return 0;
}
- if (DBIS->debug >= 6 || dbd_verbose >= 6 ) {
- PerlIO_printf(DBILOGFP, "Geting the properties of object named
=%s at level %d\n",obj->type_name,level);
- }
-
-
OCITypeByName_log_stat(imp_sth->envhp,imp_sth->errhp,imp_sth->svchp,obj->type_name,obj->type_namel,&obj->tdo,status);
-
+
OCITypeByRef_log_stat(imp_sth->envhp,imp_sth->errhp,type_ref,&obj->tdo,status);
+
if (status != OCI_SUCCESS) {
- oci_error(sth, imp_sth->errhp, status, "OCITypeByName");
+ oci_error(sth, imp_sth->errhp, status, "OCITypeByRef");
return 0;
}
+
+ return describe_obj_by_tdo(sth, imp_sth, obj, level);
+ }
+
+int
+describe_obj_by_tdo(SV *sth,imp_sth_t *imp_sth,fbh_obj_t *obj,int level ) {
+ dTHX;
+ sword status;
+ text *type_name, *schema_name;
+ ub4 type_namel, schema_namel;
+
+
OCIDescribeAny_log_stat(imp_sth->svchp,imp_sth->errhp,obj->tdo,(ub4)0,OCI_OTYPE_PTR,(ub1)1,OCI_PTYPE_TYPE,imp_sth->dschp,status);
/*we have the Actual TDO so lets see what it is made up of by a
describe*/
-
+
if (status != OCI_SUCCESS) {
oci_error(sth,imp_sth->errhp, status, "OCIDescribeAny");
return 0;
}
OCIAttrGet_parmap(imp_sth, imp_sth->dschp,OCI_HTYPE_DESCRIBE,
&obj->parmdp, 0, status);
-
+
if (status != OCI_SUCCESS) {
oci_error(sth,imp_sth->errhp, status, "OCIAttrGet");
return 0;
@@ -2313,15 +2412,39 @@
/*and we store it in the object's paramdp for now*/
- OCIAttrGet_parmdp(imp_sth, obj->parmdp, (dvoid *)&obj->typecode, 0,
OCI_ATTR_TYPECODE, status);
+ OCIAttrGet_parmdp(imp_sth, obj->parmdp, &schema_name, &schema_namel,
OCI_ATTR_SCHEMA_NAME, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth,imp_sth->errhp, status, "OCIAttrGet");
+ return 0;
+ }
+
+ OCIAttrGet_parmdp(imp_sth, obj->parmdp, &type_name, &type_namel,
OCI_ATTR_NAME, status);
+
+ if (status != OCI_SUCCESS) {
+ oci_error(sth,imp_sth->errhp, status, "OCIAttrGet");
+ return 0;
+ }
+
+ /* make full type_name: schema_name + "." + type_name */
+ obj->full_type_name = newSVpv((char*)schema_name, schema_namel);
+ sv_catpvn(obj->full_type_name, ".", 1);
+ sv_catpvn(obj->full_type_name, (char*)type_name, type_namel);
+ obj->type_name = (text*)SvPV(obj->full_type_name,na);
/*we need to know its type code*/
+ OCIAttrGet_parmdp(imp_sth, obj->parmdp, (dvoid *)&obj->typecode, 0,
OCI_ATTR_TYPECODE, status);
+
if (status != OCI_SUCCESS) {
oci_error(sth,imp_sth->errhp, status, "OCIAttrGet");
return 0;
}
+ if (DBIS->debug >= 6 || dbd_verbose >= 6 ) {
+ PerlIO_printf(DBILOGFP, "Geting the properties of object named
=%s at level %d\n",obj->type_name,level);
+ }
+
if (obj->typecode == OCI_TYPECODE_OBJECT){
OCIParam *list_attr= (OCIParam *) 0;
ub2 pos;
@@ -2755,11 +2878,11 @@
fbh->disize =
fbh->disize+long_readlen; /*user set max value for the fetch*/
if (fbh->dbtype == ORA_CLOB){
fbh->ftype = SQLT_CHR;
- }
+ }
else {
fbh->ftype = SQLT_LVB; /*Binary
form seems this is the only value where we cna get the length correctly*/
}
- }
+ }
else if (imp_sth->clbk_lob){ /*get by peice
with callback a slow*/
fbh->clbk_lob = 1;
fbh->define_mode =
OCI_DYNAMIC_FETCH; /* piecwise fetch*/
@@ -2775,7 +2898,7 @@
fbh->ftype = SQLT_BIN; /*other
Binary*/
}
fbh->fetch_func = fetch_clbk_lob;
- }
+ }
else if (imp_sth->piece_lob){ /*get by peice
with polling slowest*/
fbh->piece_lob = 1;
fbh->define_mode =
OCI_DYNAMIC_FETCH; /* piecwise fetch*/
@@ -2792,7 +2915,7 @@
fbh->ftype = SQLT_BIN; /*other
Binary */
}
fbh->fetch_func = fetch_get_piece;
- }
+ }
else { /*auto lob fetch with locator by far the
fastest*/
fbh->disize = fbh->dbsize *10 ; /* XXX!
*/
fbh->fetch_func = (imp_sth->auto_lob) ?
fetch_func_autolob : fetch_func_getrefpv;
@@ -2996,14 +3119,14 @@
for(i=0; i < num_fields; ++i) {
imp_fbh_t *fbh = &imp_sth->fbh[i];
- if (fbh->fetch_cleanup)
+ if (fbh->fetch_cleanup)
fbh->fetch_cleanup(sth, fbh);
}
if (ora_fetchtest && DBIc_ROW_COUNT(imp_sth)>0) {
--ora_fetchtest; /* trick for testing performance */
status = OCI_SUCCESS;
- }
+ }
else {
if (DBIS->debug >= 3 || dbd_verbose >= 3 ){
PerlIO_printf(DBILOGFP, " dbd_st_fetch %d
fields...\n", DBIc_NUM_FIELDS(imp_sth));
@@ -3040,7 +3163,7 @@
status=OCI_SUCCESS;
else
status=imp_sth->rs_array_status;
- }
+ }
else {
OCIStmtFetch_log_stat(imp_sth->stmhp,
imp_sth->errhp,1,(ub2)OCI_FETCH_NEXT, OCI_DEFAULT, status);
imp_sth->rs_array_idx=0;
@@ -3081,7 +3204,7 @@
ChopBlanks = DBIc_has(imp_sth, DBIcf_ChopBlanks);
err = 0;
-
+
for(i=0; i < num_fields; ++i) {
imp_fbh_t *fbh = &imp_sth->fbh[i];
fb_ary_t *fb_ary = fbh->fb_ary;
@@ -3116,7 +3239,7 @@
if (!fbh->fetch_func(sth, fbh, sv)){
++err; /* fetch_func already called
oci_error */
}
- }
+ }
else {
int datalen =
fb_ary->arlen[imp_sth->rs_array_idx];
char *p = (char*)row_data;
@@ -3125,7 +3248,7 @@
Seems I have to use SQLT_LVB to
get the length all other will fail*/
datalen = *(ub4*)row_data;
sv_setpvn(sv, (char*)row_data+
sizeof(ub4), datalen);
- }
+ }
else {
if (ChopBlanks && fbh->dbtype == 96) {
while(datalen && p[datalen -
1]==' ')
@@ -3138,10 +3261,10 @@
}
}
- }
+ }
else if (rc == 1405) { /* field is null - return undef */
sv_set_undef(sv);
- }
+ }
else { /* See odefin rcode arg description in OCI docs */
char buf[200];
char *hint = "";
@@ -3160,7 +3283,7 @@
hint = ", LongReadLen too small and/or
LongTruncOk not set";
}
- }
+ }
else { /* set field that caused error to undef */
sv_set_undef(sv);
}
@@ -3196,15 +3319,15 @@
if (**uidp == '\0' && **pwdp == '\0') {
return OCI_CRED_EXT;
}
-
+
OCIAttrSet_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,
*uidp, strlen(*uidp),
(ub4) OCI_ATTR_USERNAME, imp_dbh->errhp, status);
-
+
OCIAttrSet_log_stat(imp_dbh->authp, OCI_HTYPE_SESSION,
(strlen(*pwdp)) ? *pwdp : NULL, strlen(*pwdp),
(ub4) OCI_ATTR_PASSWORD, imp_dbh->errhp, status);
-
+
return OCI_CRED_RDBMS;
}
@@ -3402,7 +3525,7 @@
OCIDescribeAny_log_stat(imp_sth->svchp, errhp, tablename,
strlen(tablename),
(ub1)OCI_OTYPE_NAME, (ub1)1, (ub1)OCI_PTYPE_TABLE,
imp_sth->dschp, status);
-
+
if (status != OCI_SUCCESS) {
/* XXX this OCI_PTYPE_TABLE->OCI_PTYPE_VIEW fallback should actually be
*/
/* a loop that includes synonyms etc */
@@ -3420,12 +3543,12 @@
OCIAttrGet_log_stat(parmhp, OCI_DTYPE_PARAM,
&numcols, 0, OCI_ATTR_NUM_COLS, errhp, status);
}
-
+
if (!status ) {
OCIAttrGet_log_stat(parmhp, OCI_DTYPE_PARAM,
&collisthd, 0, OCI_ATTR_LIST_COLUMNS, errhp,
status);
}
-
+
if (status != OCI_SUCCESS) {
OCIHandleFree_log_stat(imp_sth->dschp, OCI_HTYPE_DESCRIBE,
status);
return oci_error(sth, errhp, status,
"OCIDescribeAny/OCIAttrGet/LOB refetch");
@@ -3446,44 +3569,44 @@
OCI_ATTR_DATA_TYPE,
errhp, status);
if (status)
break;
-
+
OCIAttrGet_log_stat(colhd, OCI_DTYPE_PARAM, &col_name,
&col_name_len,
OCI_ATTR_NAME, errhp, status);
if (status)
break;
-
+
if (DBIS->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(DBILOGFP, " lob refetch
table col %d: '%.*s' otype %d\n",
(int)i, (int)col_name_len,col_name, col_dbtype);
-
+
if (col_dbtype != SQLT_CLOB && col_dbtype != SQLT_BLOB)
continue;
-
+
if (!lob_cols_hv)
lob_cols_hv = newHV();
-
+
sv = newSViv(col_dbtype);
(void)sv_setpvn(sv, col_name, col_name_len);
-
+
if (CSFORM_IMPLIES_UTF8(SQLCS_IMPLICIT))
SvUTF8_on(sv);
-
+
(void)SvIOK_on(sv); /* "what a wonderful hack!" */
(void)hv_store(lob_cols_hv, col_name,col_name_len, sv,0);
OCIDescriptorFree(colhd, OCI_DTYPE_PARAM);
colhd = NULL;
}
-
+
if (colhd)
OCIDescriptorFree(colhd, OCI_DTYPE_PARAM);
-
+
if (status != OCI_SUCCESS) {
oci_error(sth, errhp, status,
"OCIDescribeAny/OCIParamGet/OCIAttrGet/LOB refetch");
OCIHandleFree_log_stat(imp_sth->dschp, OCI_HTYPE_DESCRIBE,
status);
return 0;
}
-
+
if (!lob_cols_hv)
return oci_error(sth, errhp, OCI_ERROR,
"LOB refetch failed, no lobs in table");
@@ -3505,15 +3628,15 @@
while( (sv = hv_iternextsv(imp_sth->all_params_hv, &p, &i)) != NULL ) {
int matched = 0;
phs_t *phs = (phs_t*)(void*)SvPVX(sv);
-
+
if (sv == &sv_undef || !phs)
croak("panic: unbound params");
-
+
if (phs->ftype != SQLT_CLOB && phs->ftype != SQLT_BLOB)
continue;
-
+
hv_iterinit(lob_cols_hv);
-
+
while( (sv = hv_iternextsv(lob_cols_hv, &p, &i)) != NULL ) {
char sql_field[200];
if (phs->ora_field) { /* must match this phs by field
name */
@@ -3572,7 +3695,7 @@
}
}
sv_free((SV*)lob_cols_hv);
-
+
if (unmatched_params) {
Safefree(lr);
return oci_error(sth, errhp, OCI_ERROR,
@@ -3594,7 +3717,7 @@
OCIStmtPrepare_log_stat(lr->stmthp, errhp,
(text*)SvPVX(sql_select), SvCUR(sql_select), OCI_NTV_SYNTAX,
OCI_DEFAULT, status);
-
+
if (status != OCI_SUCCESS) {
OCIHandleFree(lr->stmthp, OCI_HTYPE_STMT);
Safefree(lr);
@@ -3693,12 +3816,12 @@
lr = imp_sth->lob_refetch;
OCIAttrGet_stmhp_stat(imp_sth, lr->rowid, 0, OCI_ATTR_ROWID,status);
-
+
if (status != OCI_SUCCESS)
return oci_error(sth, errhp, status, "OCIAttrGet OCI_ATTR_ROWID
/LOB refetch");
-
+
OCIStmtExecute_log_stat(imp_sth->svchp, lr->stmthp, errhp,1, 0, NULL,
NULL, OCI_DEFAULT, status); /* execute and fetch */
-
+
if (status != OCI_SUCCESS)
return oci_error(sth, errhp, status,
@@ -3711,7 +3834,7 @@
ub4 amtp;
if(SvUPGRADE(phs->sv, SVt_PV)){/* For GCC not to warn on unused
result */ }; /* just in case */
-
+
amtp = SvCUR(phs->sv); /* XXX UTF8? */
if (rc == 1405) { /* NULL - return undef */
sv_set_undef(phs->sv);
@@ -3747,22 +3870,22 @@
if (status != OCI_SUCCESS) {
return oci_error(sth, errhp, status,
"OCILobWrite in post_execute_lobs");
}
-
+
} else { /* amtp==0 so truncate LOB to
zero length */
OCILobTrim_log_stat(imp_sth->svchp, errhp,
(OCILobLocator*)fbh->desc_h, 0, status);
-
+
if (status != OCI_SUCCESS) {
return oci_error(sth, errhp, status,
"OCILobTrim in post_execute_lobs");
}
-
+
}
-
+
if (DBIS->debug >= 3 || dbd_verbose >= 3 )
PerlIO_printf(DBILOGFP,
" lob refetch %d for '%s' param: ftype
%d, len %ld: %s %s\n",
i+1,fbh->name, fbh->dbtype, ul_t(amtp),
(rc==1405 ? "NULL" : (amtp > 0) ? "LobWrite" :
"LobTrim"), oci_status_name(status));
-
+
if (status != OCI_SUCCESS) {
return oci_error(sth, errhp, status,
"OCILobTrim/OCILobWrite/LOB refetch");
}
@@ -3784,10 +3907,10 @@
if (lr->rowid)
OCIDescriptorFree(lr->rowid, OCI_DTYPE_ROWID);
OCIHandleFree_log_stat(lr->stmthp, OCI_HTYPE_STMT, status);
-
+
if (status != OCI_SUCCESS)
oci_error(sth, imp_sth->errhp, status,
"ora_free_lob_refetch/OCIHandleFree");
-
+
for(i=0; i < lr->num_fields; ++i) {
imp_fbh_t *fbh = &lr->fbh_ary[i];
ora_free_fbh_contents(fbh);
Modified: dbd-oracle/trunk/ocitrace.h
==============================================================================
--- dbd-oracle/trunk/ocitrace.h (original)
+++ dbd-oracle/trunk/ocitrace.h Wed Jan 14 07:28:59 2009
@@ -191,6 +191,14 @@
OciTp, (void*)envhp, (void*)errhp, (void*)svchp,
(char*)(p1),(l),oci_status_name(stat)),stat \
: stat
+#define OCITypeByRef_log_stat(envhp,errhp,ref,tdo,stat)\
+ stat =
OCITypeByRef(envhp,errhp,ref,OCI_DURATION_TRANS,OCI_TYPEGET_ALL,tdo);\
+ (DBD_OCI_TRACEON) \
+ ? PerlIO_printf(DBD_OCI_TRACEFP,\
+ "%sTypeByRef(%p,%p,%p)=%s\n",\
+ OciTp, (void*)envhp, (void*)errhp,
(void*)ref,oci_status_name(stat)),stat \
+ : stat
+
/* added by lab */
#define OCILobCharSetId_log_stat( envhp, errhp, locp, csidp, stat ) \
stat = OCILobCharSetId( envhp, errhp, locp, csidp ); \
@@ -343,7 +351,7 @@
#define OCIInitialize_log_stat(md,cp,mlf,rlf,mfp,stat)
\
stat=OCIInitialize(md,cp,mlf,rlf,mfp); \
(DBD_OCI_TRACEON) ? PerlIO_printf(DBD_OCI_TRACEFP,
\
- "%sInitialize(%lu,with mode =%s %p,%p,%p,%p)=%s\n",
\
+ "%sInitialize(with mode =%s %lu,%p,%p,%p,%p)=%s\n",
\
OciTp,
oci_mode(md),ul_t(md),(void*)cp,(void*)mlf,(void*)rlf,(void*)mfp, \
oci_status_name(stat)),stat : stat
Added: dbd-oracle/trunk/t/58object.t
==============================================================================
--- (empty file)
+++ dbd-oracle/trunk/t/58object.t Wed Jan 14 07:28:59 2009
@@ -0,0 +1,153 @@
+#!perl -w
+
+use DBI;
+use DBD::Oracle qw(ORA_RSET SQLCS_NCHAR);
+use strict;
+use Data::Dumper;
+
+use Test::More tests => 34;
+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");
+
+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;
