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