DBD-SQLAnywhere
view release on metacpan or search on metacpan
phs_sv = newSVpv( (char*)&phs_tpl, sizeof(phs_tpl) );
if( ph_name == NULL ) {
ph_name = _ph_name_buf;
sprintf( ph_name, ":p%d", curr_ordinal );
ph_name_len = strlen( ph_name );
}
hv_store( imp_sth->bind_names, ph_name, (I32)ph_name_len,
phs_sv, 0 );
++curr_ordinal;
/* warn("bind_names: '%s'\n", start); */
} else {
*dest++ = *src++;
}
}
*dest = '\0';
if( DBIS->debug >= 2 ) {
PerlIO_printf( DBILOGFP, "\nPreparse transformed statement: '%s'\n", imp_sth->sql_statement );
}
if( imp_sth->bind_names ) {
imp_sth->num_bind_params_scanned = (int)HvKEYS(imp_sth->bind_names);
if( DBIS->debug >= 2 ) {
PerlIO_printf( DBILOGFP, "scanned %d distinct placeholders\n",
imp_sth->num_bind_params_scanned );
}
}
}
int
dbd_bind_ph( SV *sth,
imp_sth_t *imp_sth,
SV *ph_namesv,
SV *newvalue,
IV sql_type,
SV *attribs,
int is_inout,
IV maxlen )
/******************************/
{
dTHX;
D_imp_dbh_from_sth;
SV **svp;
STRLEN name_len;
char *name;
phs_t *phs;
char buf[10];
if( SvNIOK( ph_namesv ) ) { /* passed as a number */
name = buf;
sprintf( name, ":p%d", (int)SvIV( ph_namesv ) );
name_len = strlen(name);
} else {
name = SvPV( ph_namesv, name_len );
}
// FIXME: Why croak() and not just report an error?
if( SvTYPE(newvalue) > SVt_PVLV ) { /* hook for later array logic */
croak( "Can't bind a non-scalar value" );
}
if( SvROK(newvalue) && !IS_DBI_HANDLE(newvalue) ) {
/* dbi handle allowed for cursor variables */
croak( "Can't bind a reference (%s)", neatsvpv(newvalue,0) );
}
if( SvTYPE(newvalue) == SVt_PVLV && is_inout ) { /* may allow later */
croak( "Can't bind ``lvalue'' mode scalar as inout parameter" );
}
if( DBIS->debug >= 2 ) {
PerlIO_printf( DBILOGFP, " bind %s <== %s (type %ld",
name, neatsvpv(newvalue,0), (long)sql_type );
if( is_inout ) {
PerlIO_printf( DBILOGFP, ", inout 0x%p", newvalue );
}
if( attribs ) {
PerlIO_printf( DBILOGFP, ", attribs: %s", SvPV(attribs,PL_na) );
}
PerlIO_printf( DBILOGFP, ")\n" );
}
svp = hv_fetch( imp_sth->bind_names, name, (I32)name_len, 0 );
if( svp == NULL ) {
croak( "Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0) );
}
if( is_inout && SvREADONLY( newvalue ) ) {
croak( "%s", PL_no_modify );
}
phs = (phs_t *)((void*)SvPVX(*svp)); /* placeholder struct */
if( phs->ordinal == 0 ) {
croak( "bind_param internal error: unknown ordinal for '%s'\n", name );
}
if( phs->sv != &PL_sv_undef ) { /* first bind for this placeholder */
SvREFCNT_dec( phs->sv );
}
phs->sv = SvREFCNT_inc( newvalue );
phs->is_inout = is_inout;
phs->maxlen = maxlen;
phs->sql_type = (int)sql_type;
if( DBIS->debug >= 2 ) {
PerlIO_printf( DBILOGFP, "Binding input hostvar '%s' to ordinal %d\n",
name, phs->ordinal );
}
return( 1 );
}
static int
assign_from_result_set( pTHX_ SV *sth, imp_sth_t *imp_sth, SV *sv, int index )
/****************************************************************************/
{
D_imp_dbh_from_sth;
a_sqlany_data_info dinfo;
SACAPI *sacapi = imp_dbh->sacapi;
if( !sacapi->api.sqlany_get_data_info( imp_sth->statement, index, &dinfo ) ) {
/***********************************************************/
{
D_imp_dbh_from_sth;
HE *he;
HV *hv;
SV *sv;
phs_t *phs;
SACAPI *sacapi = imp_dbh->sacapi;
hv = imp_sth->bind_names;
if( hv == NULL ) {
return( TRUE );
}
hv_iterinit( hv );
while( (he=hv_iternext( hv )) != NULL ) {
sv = hv_iterval( hv, he );
phs = (phs_t *)((void *)SvPVX(sv)); /* placeholder struct */
if( phs->ordinal != 0 && phs->ordinal <= imp_sth->num_bind_params ) {
a_sqlany_bind_param desc;
if( !sacapi->api.sqlany_describe_bind_param( imp_sth->statement, phs->ordinal-1, &desc ) ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "failed to get description for bind param" );
return( FALSE );
}
if( phs->is_inout && (desc.direction&DD_OUTPUT) ) {
a_sqlany_bind_param_info bp;
if( !sacapi->api.sqlany_get_bind_param_info( imp_sth->statement, phs->ordinal-1, &bp ) ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "failed to get bind param info" );
return( FALSE );
}
if( phs->out_param_is_null ) {
SvOK_off( phs->sv ); // undef
} else {
STRLEN len = (STRLEN)phs->out_param_length;
if( (SvLEN( phs->sv ) < len+1) || (SvPVX( phs->sv ) != bp.output_value.buffer) ) {
// This shouldn't happen -- we already grew the dest fit the data
croak( "internal error: output buffer for bind parameter %d changed", phs->ordinal );
}
SvCUR_set( phs->sv, len );
*SvEND( phs->sv ) = '\0';
SvPOK_only( phs->sv );
}
}
}
}
return( TRUE );
}
int
dbd_st_execute( SV *sth, imp_sth_t *imp_sth )
/*******************************************/
// return value <= -2:error, >=0:ok row count, (-1=unknown count) */
{
dTHR;
dTHX;
D_imp_dbh_from_sth;
int do_commit = FALSE;
int sqlcode;
int num_cols;
SACAPI *sacapi = imp_dbh->sacapi;
// If a cursor is still open, it must be closed before we open another
// one on the same handle.
dbd_st_finish( sth, imp_sth );
if( !really_bind( aTHX_ sth, imp_sth ) ) {
return( -2 );
}
sacapi->api.sqlany_execute( imp_sth->statement );
sqlcode = sacapi->api.sqlany_error( imp_dbh->conn, NULL, 0 );
num_cols = sacapi->api.sqlany_num_cols( imp_sth->statement );
// A failure to execute or there is no cursor open
if( sqlcode == SQLE_NOTFOUND ) {
// num_cols == 0 implies it was execute-only (and no cursor)
if( num_cols == 0 && !assign_output_parameters( aTHX_ sth, imp_sth ) ) {
return( -2 );
}
sv_setpv( DBIc_ERR(imp_sth), "" );
return( 0 ); // No rows affected
}
// This error case for SQLE_TRUNCATED as well because there is no
// way to call GET DATA without a cursor.
if( sqlcode < 0 ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "execute failed" );
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_execute failed, rc=%d", sqlcode );
}
return( -2 );
}
if( sqlcode > 0 ) {
// Just a warning
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "warning during execute" );
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_execute warning, rc=%d", sqlcode );
}
}
if( num_cols == 0 ) {
// executed already & no cursor
if( !assign_output_parameters( aTHX_ sth, imp_sth ) ) {
return( -2 );
}
imp_sth->row_count = sacapi->api.sqlany_affected_rows( imp_sth->statement );
if( DBIc_has(imp_dbh,DBIcf_AutoCommit) ) {
sacapi->api.sqlany_commit( imp_dbh->conn );
}
} else {
// A cursor is open
if( DBIS->debug >= 2 ) {
PerlIO_printf( DBILOGFP, "Cursor opened\n" );
}
imp_sth->row_count = sacapi->api.sqlany_num_rows( imp_sth->statement );
}
DBIc_NUM_FIELDS(imp_sth) = num_cols;
DBIc_ACTIVE_on(imp_sth);
// Negative row-counts are estimates but dbperl wants a positive
return( imp_sth->row_count < 0 ? -imp_sth->row_count : imp_sth->row_count );
}
AV *
dbd_st_fetch( SV *sth, imp_sth_t *imp_sth )
/*****************************************/
{
dTHX;
D_imp_dbh_from_sth;
int debug = DBIS->debug;
int num_fields;
int i;
AV *av;
int sqlcode;
SACAPI *sacapi = imp_dbh->sacapi;
/* Check that execute() was executed sucessfuly. */
if( !DBIc_ACTIVE(imp_sth) ) {
ssa_error( aTHX_ sth, NULL, SQLE_CURSOR_NOT_OPEN, "no statement executing" );
return( Nullav );
}
if( imp_sth->statement == NULL || DBIc_NUM_FIELDS(imp_sth) == 0 ) {
return( Nullav ); // we figured it was just an EXECUTE
}
// printf( "Fetch (%p)\n", imp_sth ); fflush( stdout );
sacapi->api.sqlany_fetch_next( imp_sth->statement );
sqlcode = sacapi->api.sqlany_error( imp_dbh->conn, NULL, 0 );
if( sqlcode == SQLE_NOTFOUND ) {
sv_setpv( DBIc_ERR(imp_sth), "" ); /* just end-of-fetch */
return( Nullav );
} else if( sqlcode < 0 ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "fetch failed" );
if( debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_fetch failed, rc=%d", sqlcode );
}
return( Nullav );
}
if( sqlcode > 0 ) {
// Just a warning
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "warning during fetch" );
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_fetch warning, rc=%d", sqlcode );
}
}
av = DBIS->get_fbav( imp_sth );
// printf( "More_results (%p)\n", imp_sth ); fflush( stdout );
rescode = sacapi->api.sqlany_get_next_result( imp_sth->statement );
sqlcode = sacapi->api.sqlany_error( imp_dbh->conn, NULL, 0 );
// rescode == 0 means no more results
if( rescode == 0 ) {
if( sqlcode == SQLE_NOTFOUND || sqlcode == SQLE_PROCEDURE_COMPLETE ) {
sv_setpv( DBIc_ERR(imp_sth), "" ); /* just end-of-results */
return( -1 );
} else {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "more_results failed" );
if( debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_more_results failed, rc=%d", sqlcode );
}
return( 0 );
}
}
DBIc_NUM_FIELDS(imp_sth) = sacapi->api.sqlany_num_cols( imp_sth->statement );
DBIS->set_attr_k(sth, sv_2mortal(newSVpvn("NUM_OF_FIELDS",13)), 0,
sv_2mortal(newSViv(sacapi->api.sqlany_num_cols( imp_sth->statement ))));
if( sqlcode > 0 ) {
// Just a warning
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "warning during more_results" );
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, " dbd_st_more_results warning, rc=%d", sqlcode );
}
}
return( 1 );
}
int
dbd_st_blob_read( SV *sth, imp_sth_t *imp_sth,
int field, long offset, long len, SV *destrv, long destoffset )
/*******************************************************************************/
{
dTHX;
D_imp_dbh_from_sth;
SV *bufsv;
a_sqlany_data_info dinfo;
char *dest;
int retlen;
SACAPI *sacapi = imp_dbh->sacapi;
/* Check that execute() was executed sucessfuly. This also implies */
/* that dbd_describe() executed sucessfuly so the memory buffers */
/* are allocated and bound. */
if( !DBIc_ACTIVE(imp_sth) ) {
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, "blob_read on inactive handle\n" );
}
ssa_error( aTHX_ sth, NULL, SQLE_CURSOR_NOT_OPEN, "no statement executing" );
return( 0 );
}
if( imp_sth->statement == NULL ) {
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, "blob_read on non-cursor statement\n" );
}
return( 0 ); // we figured it was just an EXECUTE
}
if( field >= sacapi->api.sqlany_num_cols( imp_sth->statement ) ) {
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, "blob_read: field number too large\n" );
}
return( 0 );
}
if( !sacapi->api.sqlany_get_data_info( imp_sth->statement, field, &dinfo ) ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "get_data_info failed" );
return( 0 );
}
if( dinfo.type != A_STRING && dinfo.type != A_BINARY ) {
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP, "blob_read: field is neither string nor binary\n" );
}
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "blob_read: field is neither string nor binary\n" );
return( 0 );
}
if( dinfo.is_null ) {
return( 0 );
}
bufsv = SvRV( destrv );
sv_setpvn( bufsv, "", 0 ); /* ensure it's writable string */
dest = SvGROW( bufsv, (STRLEN)destoffset+len+1 ); /* SvGROW doesn't do +1 */
dest += destoffset;
retlen = sacapi->api.sqlany_get_data( imp_sth->statement, field, offset, dest, len );
if( retlen < 0 ) {
ssa_error( aTHX_ sth, imp_dbh->conn, SQLE_ERROR, "get_data failed" );
return( 0 );
}
if( DBIS->debug >= 3 ) {
PerlIO_printf( DBILOGFP,
" blob_read field %d, type %d, offset %ld (ignored), len %ld, destoffset %ld, retlen %ld\n",
field, dinfo.type, offset, len, destoffset, (long)retlen );
}
SvCUR_set( bufsv, destoffset + retlen );
*SvEND(bufsv) = '\0'; /* consistent with perl sv_setpvn etc */
if( retlen == 0 ) {
return( 0 );
}
return( 1 );
}
int
dbd_st_rows( SV *sth, imp_sth_t *imp_sth )
/****************************************/
{
( run in 1.163 second using v1.01-cache-2.11-cpan-e1769b4cff6 )