/*
$Id: InterBase.xs,v 1.55 2006/10/25 16:13:18 edpratomo Exp $
Copyright (c) 1999-2006 Edwin Pratomo
Portions Copyright (c) 2001-2005 Daniel Ritz
You may distribute under the terms of either the GNU General Public
License or the Artistic License, as specified in the Perl README file,
with the exception that it cannot be placed on a CD-ROM or similar media
for commercial distribution without the prior approval of the author.
*/
#include "InterBase.h"
DBISTATE_DECLARE;
static int _cancel_callback(SV *dbh, IB_EVENT *ev)
{
ISC_STATUS status[ISC_STATUS_LENGTH];
D_imp_dbh(dbh);
int ret = 0;
if (ev->exec_cb)
croak("Can't be called from inside a callback");
if (ev->perl_cb) {
ev->state = INACTIVE;
SvREFCNT_dec(ev->perl_cb);
ev->perl_cb = (SV*)NULL;
isc_cancel_events(status, &(imp_dbh->db), &(ev->id));
if (ib_error_check(dbh, status))
ret = 0;
else
ret = 1;
} else
croak("No callback found for this event handle. Have you called ib_register_callback?");
return ret;
}
static int _call_perlsub(IB_EVENT ISC_FAR *ev, short length,
#if defined(INCLUDE_TYPES_PUB_H)
const ISC_UCHAR *updated
#else
char ISC_FAR *updated
#endif
)
{
int retval = 1;
#if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY)
/* save context, set context from dbh */
void *context = PERL_GET_CONTEXT;
PERL_SET_CONTEXT(ev->dbh->context);
{
#else
void *context = PERL_GET_CONTEXT;
PerlInterpreter *cb_perl = perl_alloc();
PERL_SET_CONTEXT(cb_perl);
{
#endif
dSP;
int i, count;
SV **svp;
HV *posted_events = newHV();
ISC_ULONG ecount[15];
#if defined(INCLUDE_TYPES_PUB_H)
ISC_UCHAR *result = ev->result_buffer;
#else
char ISC_FAR *result = ev->result_buffer;
#endif
while (length--)
*result++ = *updated++;
isc_event_counts(ecount, ev->epb_length, ev->event_buffer,
ev->result_buffer);
for (i = 0; i < ev->num; i++)
{
if (ecount[i])
{
svp = hv_store(posted_events, *(ev->names + i), strlen(*(ev->names + i)),
newSViv(ecount[i]), 0);
if (svp == NULL)
croak("Bad: key '%s' not stored", *(ev->names + i));
}
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_noinc((SV*)posted_events)));
PUTBACK;
count = perl_call_sv(ev->perl_cb, G_SCALAR);
SPAGAIN;
if (count > 0)
retval = POPi;
PUTBACK;
FREETMPS;
LEAVE;
#if defined(USE_THREADS) || defined(USE_ITHREADS) || defined(MULTIPLICITY)
}
/* restore old context*/
PERL_SET_CONTEXT(context);
#else
}
PERL_SET_CONTEXT(context);
perl_free(cb_perl);
#endif
return retval;
}
/* callback function for events, called by InterBase */
/* static isc_callback _async_callback(IB_EVENT ISC_FAR *ev, short length, char ISC_FAR *updated) */
static ISC_EVENT_CALLBACK _async_callback(IB_EVENT ISC_FAR *ev,
#if defined(INCLUDE_TYPES_PUB_H)
ISC_USHORT length, const ISC_UCHAR *updated
#else
short length, char ISC_FAR *updated
#endif
)
{
ISC_STATUS status[ISC_STATUS_LENGTH];
switch (ev->state) {
case INACTIVE:
break;
case ACTIVE:
ev->exec_cb = 1;
if (_call_perlsub(ev, length, updated) == 0) {
ev->state = INACTIVE;
ev->exec_cb = 0;
break;
}
ev->exec_cb = 0;
isc_que_events(
status,
&(ev->dbh->db),
&(ev->id),
ev->epb_length,
ev->event_buffer,
(ISC_EVENT_CALLBACK)_async_callback,
ev
);
}
return (0);
}
MODULE = DBD::InterBase PACKAGE = DBD::InterBase
INCLUDE: InterBase.xsi
MODULE = DBD::InterBase PACKAGE = DBD::InterBase::db
void
_do(dbh, statement, attr=Nullsv)
SV * dbh
SV * statement
SV * attr
PROTOTYPE: $$;$@
CODE:
{
D_imp_dbh(dbh);
ISC_STATUS status[ISC_STATUS_LENGTH]; /* isc api status vector */
STRLEN slen;
int retval;
char *sbuf = SvPV(statement, slen);
DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "db::_do\n" "Executing : %s\n", sbuf));
/* we need an open transaction */
if (!imp_dbh->tr)
{
DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "starting new transaction..\n"));
if (!ib_start_transaction(dbh, imp_dbh))
{
retval = -2;
XST_mUNDEF(0); /* <= -2 means error */
return;
}
DBI_TRACE_imp_xxh(imp_dbh, 1, (DBIc_LOGPIO(imp_dbh), "new transaction started.\n"));
}
/* only execute_immediate statment if NOT in soft commit mode */
if (!(imp_dbh->soft_commit))
{
isc_dsql_execute_immediate(status, &(imp_dbh->db), &(imp_dbh->tr), 0,
sbuf, imp_dbh->sqldialect, NULL);
if (ib_error_check(dbh, status))
retval = -2;
else
retval = -1 ;
}
/* for AutoCommit: prepare/getinfo/exec statment (count DDL statements)
* an easier and also working way would be to do that from perl with
* $sth = $dbh->prepare(...); $sth->execute();
* but this way is much faster (no bind params, etc.)
*/
else
{
isc_stmt_handle stmt = 0L; /* temp statment handle */
static char stmt_info[] = { isc_info_sql_stmt_type };
char info_buffer[20]; /* statment info buffer */
retval = -2;
do
{
/* init statement handle */
if (isc_dsql_alloc_statement2(status, &(imp_dbh->db), &stmt))
break;
/* prepare statement */
isc_dsql_prepare(status, &(imp_dbh->tr), &stmt, 0, sbuf,
imp_dbh->sqldialect, NULL);
if (ib_error_check(dbh, status))
break;
/* get statement type */
if (!isc_dsql_sql_info(status, &stmt, sizeof(stmt_info), stmt_info,
sizeof(info_buffer), info_buffer))
{
/* need to count DDL statments */
short l = (short) isc_vax_integer((char *) info_buffer + 1, 2);
if (isc_vax_integer((char *) info_buffer + 3, l) == isc_info_sql_stmt_ddl)
imp_dbh->sth_ddl++;
}
else
break;
/* exec the statement */
isc_dsql_execute(status, &(imp_dbh->tr), &stmt, imp_dbh->sqldialect, NULL);
if (!ib_error_check(dbh, status))
retval = -1;
} while (0);
/* close statement */
if (stmt)
isc_dsql_free_statement(status, &stmt, DSQL_drop);
if (retval != -2) retval = -1;
}
/* for AutoCommit: commit */
if (DBIc_has(imp_dbh, DBIcf_AutoCommit))
{
if (!ib_commit_transaction(dbh, imp_dbh))
retval = -2;
}
if (retval < -1)
XST_mUNDEF(0);
else
XST_mIV(0, retval); /* typically 1, rowcount or -1 */
}
void
_ping(dbh)
SV * dbh
CODE:
{
int ret;
ret = dbd_db_ping(dbh);
if (ret == 0)
XST_mUNDEF(0);
else
XST_mIV(0, ret);
}
void
ib_set_tx_param(dbh, ...)
SV *dbh
ALIAS:
set_tx_param = 1
PREINIT:
STRLEN len;
char *tx_key, *tx_val, *tpb, *tmp_tpb;
int i, rc = 0;
int tpb_len;
char am_set = 0, il_set = 0, ls_set = 0;
I32 j;
AV *av;
HV *hv;
SV *sv, *sv_value;
HE *he;
CODE:
{
D_imp_dbh(dbh);
PERL_UNUSED_VAR(ix); /* -Wall */
/* if no params or first parameter = 0 or undef -> reset TPB to NULL */
if (items < 3)
{
if ((items == 1) || !(SvTRUE(ST(1))))
{
tpb = NULL;
tmp_tpb = NULL;
tpb_len = 0;
goto do_set_tpb;
}
}
/* we need to know the max. size of TBP, (buffer overflow problem) */
/* mem usage: -access_mode: max. 1 byte */
/* -isolation_level: max. 2 bytes */
/* -lock_resolution: max. 1 byte */
/* -reserving: max. 4 bytes + strlen(tablename) */
tpb_len = 5; /* 4 + 1 for tpb_version */
/* we need to add the length of each table name + 4 bytes */
for (i = 1; i < items-1; i += 2)
{
sv_value = ST(i + 1);
if (strEQ(SvPV_nolen(ST(i)), "-reserving"))
if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV)
{
hv = (HV *)SvRV(sv_value);
hv_iterinit(hv);
while ((he = hv_iternext(hv)))
{
/* retrieve the size of table name(s) */
HePV(he, len);
tpb_len += len + 4;
}
}
}
/* alloc it */
tmp_tpb = (char *)safemalloc(tpb_len * sizeof(char));
if (tmp_tpb == NULL)
croak("set_tx_param: Can't alloc memory");
/* do set TPB values */
tpb = tmp_tpb;
*tpb++ = isc_tpb_version3;
for (i = 1; i < items; i += 2)
{
tx_key = SvPV_nolen(ST(i));
sv_value = ST(i + 1);
/* value specified? */
if (i >= items - 1)
{
safefree(tmp_tpb);
croak("You must specify parameter => value pairs, but theres no value for %s", tx_key);
}
/**********************************************************************/
if (strEQ(tx_key, "-access_mode"))
{
if (am_set)
{
warn("-access_mode already set; ignoring second try!");
continue;
}
tx_val = SvPV_nolen(sv_value);
if (strEQ(tx_val, "read_write"))
*tpb++ = isc_tpb_write;
else if (strEQ(tx_val, "read_only"))
*tpb++ = isc_tpb_read;
else
{
safefree(tmp_tpb);
croak("Unknown -access_mode value %s", tx_val);
}
am_set = 1; /* flag */
}
/**********************************************************************/
else if (strEQ(tx_key, "-isolation_level"))
{
if (il_set)
{
warn("-isolation_level already set; ignoring second try!");
continue;
}
if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVAV)
{
av = (AV *)SvRV(sv_value);
/* sanity check */
for (j = 0; (j <= av_len(av)) && !rc; j++)
{
sv = *av_fetch(av, j, FALSE);
if (strEQ(SvPV_nolen(sv), "read_committed"))
{
rc = 1;
*tpb++ = isc_tpb_read_committed;
}
}
if (!rc)
{
safefree(tmp_tpb);
croak("Invalid -isolation_level value");
}
for (j = 0; j <= av_len(av); j++)
{
tx_val = SvPV_nolen(*(av_fetch(av, j, FALSE)));
if (strEQ(tx_val, "record_version"))
{
*tpb++ = isc_tpb_rec_version;
break;
}
else if (strEQ(tx_val, "no_record_version"))
{
*tpb++ = isc_tpb_no_rec_version;
break;
}
else if (!strEQ(tx_val, "read_committed"))
{
safefree(tmp_tpb);
croak("Unknown -isolation_level value %s", tx_val);
}
}
}
else
{
tx_val = SvPV_nolen(sv_value);
if (strEQ(tx_val, "read_committed"))
*tpb++ = isc_tpb_read_committed;
else if (strEQ(tx_val, "snapshot"))
*tpb++ = isc_tpb_concurrency;
else if (strEQ(tx_val, "snapshot_table_stability"))
*tpb++ = isc_tpb_consistency;
else
{
safefree(tmp_tpb);
croak("Unknown -isolation_level value %s", tx_val);
}
}
il_set = 1; /* flag */
}
/**********************************************************************/
else if (strEQ(tx_key, "-lock_resolution"))
{
if (ls_set)
{
warn("-lock_resolution already set; ignoring second try!");
continue;
}
if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV) {
#if defined(FB_API_VER) && FB_API_VER >= 20
hv = (HV *)SvRV(sv_value);
if (hv_exists(hv, "wait", 4)) {
*tpb++ = isc_tpb_wait;
sv = *hv_fetch(hv, "wait", 4, FALSE);
if (SvIOK(sv)) {
IV lock_timeout = SvIV(sv);
if (lock_timeout < 0) {
do_error(dbh, 2, "Wait timeout value must be positive integer");
XSRETURN_UNDEF;
} else if (lock_timeout > 0) {
*tpb++ = isc_tpb_lock_timeout;
*tpb++ = sizeof(ISC_LONG); /* length = 4 bytes */
*(ISC_LONG*)tpb = lock_timeout; /* infinite timeout */
tpb += sizeof(ISC_LONG);
}
} else {
do_error(dbh, 2, "Wait timeout value must be positive integer");
XSRETURN_UNDEF;
}
} else {
do_error(dbh, 2, "The only valid key is 'wait'");
XSRETURN_UNDEF;
}
#else
do_error(dbh, 2, "Hashref unsupported. Must be compiled with Firebird 2.0 client library");
XSRETURN_UNDEF;
#endif
} else {
tx_val = SvPV_nolen(sv_value);
if (strEQ(tx_val, "wait"))
*tpb++ = isc_tpb_wait;
else if (strEQ(tx_val, "no_wait"))
*tpb++ = isc_tpb_nowait;
else
{
safefree(tmp_tpb);
croak("Unknown transaction parameter %s", tx_val);
}
}
ls_set = 1; /* flag */
}
/**********************************************************************/
else if (strEQ(tx_key, "-reserving"))
{
if (SvROK(sv_value) && SvTYPE(SvRV(sv_value)) == SVt_PVHV)
{
char *table_name;
HV *table_opts;
hv = (HV *)SvRV(sv_value);
hv_iterinit(hv);
while ((he = hv_iternext(hv)))
{
/* check val type */
if (SvROK(HeVAL(he)) && SvTYPE(SvRV(HeVAL(he))) == SVt_PVHV)
{
table_opts = (HV*)SvRV(HeVAL(he));
if (hv_exists(table_opts, "access", 6))
{
/* access is optional */
sv = *hv_fetch(table_opts, "access", 6, FALSE);
if (strnEQ(SvPV_nolen(sv), "shared", 6))
*tpb++ = isc_tpb_shared;
else if (strnEQ(SvPV_nolen(sv), "protected", 9))
*tpb++ = isc_tpb_protected;
else
{
safefree(tmp_tpb);
croak("Invalid -reserving access value");
}
}
if (hv_exists(table_opts, "lock", 4))
{
/* lock is required */
sv = *hv_fetch(table_opts, "lock", 4, FALSE);
if (strnEQ(SvPV_nolen(sv), "read", 4))
*tpb++ = isc_tpb_lock_read;
else if (strnEQ(SvPV_nolen(sv), "write", 5))
*tpb++ = isc_tpb_lock_write;
else
{
safefree(tmp_tpb);
croak("Invalid -reserving lock value");
}
}
else /* lock */
{
safefree(tmp_tpb);
croak("Lock value is required in -reserving");
}
/* add the table name to TPB */
table_name = HePV(he, len);
*tpb++ = len + 1;
{
unsigned int k;
for (k = 0; k < len; k++)
*tpb++ = toupper(*table_name++);
}
*tpb++ = 0;
} /* end hashref check*/
else
{
safefree(tmp_tpb);
croak("Reservation for a given table must be hashref.");
}
} /* end of while() */
}
else
{
safefree(tmp_tpb);
croak("Invalid -reserving value. Must be hashref.");
}
} /* end table reservation */
else
{
safefree(tmp_tpb);
croak("Unknown transaction parameter %s", tx_key);
}
}
/* an ugly label... */
do_set_tpb:
safefree(imp_dbh->tpb_buffer);
imp_dbh->tpb_buffer = tmp_tpb;
imp_dbh->tpb_length = tpb - imp_dbh->tpb_buffer;
/* for AutoCommit: commit current transaction */
if (DBIc_has(imp_dbh, DBIcf_AutoCommit))
{
imp_dbh->sth_ddl++;
ib_commit_transaction(dbh, imp_dbh);
}
}
#*******************************************************************************
# only for use within database_info!
#define DB_INFOBUF(name, len) \
if (strEQ(item, #name)) { \
*p++ = (char) isc_info_##name; \
res_len += len + 3; \
item_buf_len++; \
continue; \
}
#define DB_RESBUF_CASEHDR(name) \
case isc_info_##name:\
keyname = #name;
HV *
ib_database_info(dbh, ...)
SV *dbh
PREINIT:
unsigned int i, count;
char item_buf[30], *p, *old_p;
char *res_buf;
short item_buf_len, res_len;
AV *av;
ISC_STATUS status[ISC_STATUS_LENGTH];
CODE:
{
D_imp_dbh(dbh);
/* process input params, count max. result buffer length */
p = item_buf;
res_len = 0;
item_buf_len = 0;
/* array or array ref? */
if (items == 2 && SvROK(ST(1)) && SvTYPE(SvRV(ST(1))) == SVt_PVAV)
{
av = (AV *)SvRV(ST(1));
count = av_len(av) + 1;
}
else
{
av = NULL;
count = items;
}
/* loop thru all elements */
for (i = 0; i < count; i++)
{
char *item;
/* fetch from array or array ref? */
if (av)
item = SvPV_nolen(*av_fetch(av, i, FALSE));
else
item = SvPV_nolen(ST(i + 1));
/* database characteristics */
DB_INFOBUF(allocation, 4);
DB_INFOBUF(base_level, 2);
DB_INFOBUF(db_id, 513);
DB_INFOBUF(implementation, 3);
DB_INFOBUF(no_reserve, 1);
#ifdef IB_API_V6
DB_INFOBUF(db_read_only, 1);
#endif
DB_INFOBUF(ods_minor_version, 1);
DB_INFOBUF(ods_version, 1);
DB_INFOBUF(page_size, 4);
DB_INFOBUF(version, 257);
#ifdef IB_API_V6
DB_INFOBUF(db_sql_dialect, 1);
#endif
/* environmental characteristics */
DB_INFOBUF(current_memory, 4);
DB_INFOBUF(forced_writes, 1);
DB_INFOBUF(max_memory, 4);
DB_INFOBUF(num_buffers, 4);
DB_INFOBUF(sweep_interval, 4);
DB_INFOBUF(user_names, 1024); /* can be more, can be less */
/* performance statistics */
DB_INFOBUF(fetches, 4);
DB_INFOBUF(marks, 4);
DB_INFOBUF(reads, 4);
DB_INFOBUF(writes, 4);
#if defined(FB_API_VER) && FB_API_VER >= 20
/* FB 2.0 */
DB_INFOBUF(active_tran_count, 4);
DB_INFOBUF(creation_date, sizeof(ISC_TIMESTAMP)); /* 2 x 4 bytes */
#endif
/* database operation counts */
/* XXX - not implemented (complicated: returns a descriptor for _each_
table...how to fetch / store this??) but do we really need these? */
}
/* the end marker */
*p++ = isc_info_end;
item_buf_len++;
/* allocate the result buffer */
res_len += 256; /* add some safety...just in case */
res_buf = (char *) safemalloc(res_len);
/* call the function */
isc_database_info(status, &(imp_dbh->db), item_buf_len, item_buf,
res_len, res_buf);
if (ib_error_check(dbh, status))
{
safefree(res_buf);
XSRETURN_UNDEF; // croak("isc_database_info failed!");
}
/* create a hash if function passed */
RETVAL = newHV();
if (!RETVAL)
{
safefree(res_buf);
// croak("unable to allocate hash return value");
do_error(dbh, 2, "unable to allocate hash return value");
XSRETURN_UNDEF;
}
/* fill the hash with key/value pairs */
for (p = res_buf; *p != isc_info_end; )
{
char *keyname;
char item = *p++;
int length = isc_vax_integer (p, 2);
p += 2;
old_p = p;
switch (item)
{
/******************************************************************/
/* database characteristics */
DB_RESBUF_CASEHDR(allocation)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(base_level)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(++p, 1)), 0);
break;
DB_RESBUF_CASEHDR(db_id)
{
HV *reshv = newHV();
ISC_LONG slen;
hv_store(reshv, "connection", 10,
(isc_vax_integer(p++, 1) == 2)?
newSVpv("local", 0):
newSVpv("remote", 0),
0);
slen = isc_vax_integer(p++, 1);
hv_store(reshv, "database", 8, newSVpvn(p, slen), 0);
p += slen;
slen = isc_vax_integer(p++, 1);
hv_store(reshv, "site", 8, newSVpvn(p, slen), 0);
hv_store(RETVAL, keyname, strlen(keyname),
newRV_noinc((SV *) reshv), 0);
break;
}
DB_RESBUF_CASEHDR(implementation)
{
HV *reshv = newHV();
hv_store(reshv, "implementation", 14,
newSViv(isc_vax_integer(++p, 1)), 0);
hv_store(reshv, "class", 5,
newSViv(isc_vax_integer(++p, 1)), 0);
hv_store(RETVAL, keyname, strlen(keyname),
newRV_noinc((SV *) reshv), 0);
break;
}
DB_RESBUF_CASEHDR(no_reserve)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
#ifdef IB_API_V6
DB_RESBUF_CASEHDR(db_read_only)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
#endif
DB_RESBUF_CASEHDR(ods_minor_version)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(ods_version)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(page_size)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(version)
{
ISC_LONG slen;
slen = isc_vax_integer(++p, 1);
hv_store(RETVAL, keyname, strlen(keyname),
newSVpvn(++p, slen), 0);
break;
}
#ifdef isc_dpb_sql_dialect
DB_RESBUF_CASEHDR(db_sql_dialect)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
#endif
/******************************************************************/
/* environmental characteristics */
DB_RESBUF_CASEHDR(current_memory)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(forced_writes)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(max_memory)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(num_buffers)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(sweep_interval)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(user_names)
{
AV *avres;
SV **svp;
ISC_LONG slen;
/* array already existing? no -> create */
if (!hv_exists(RETVAL, "user_names", 10))
{
avres = newAV();
hv_store(RETVAL, "user_names", 10,
newRV_noinc((SV *) avres), 0);
}
else
{
svp = hv_fetch(RETVAL, "user_names", 10, 0);
if (!svp || !SvROK(*svp))
{
safefree(res_buf);
croak("Error fetching hash value");
}
avres = (AV *) SvRV(*svp);
}
/* add value to the array */
slen = isc_vax_integer(p++, 1);
av_push(avres, newSVpvn(p, slen));
break;
}
/******************************************************************/
/* performance statistics */
DB_RESBUF_CASEHDR(fetches)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(marks)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(reads)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(writes)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
#if defined(FB_API_VER) && FB_API_VER >= 20
/* FB 2.0 */
DB_RESBUF_CASEHDR(active_tran_count)
hv_store(RETVAL, keyname, strlen(keyname),
newSViv(isc_vax_integer(p, (short) length)), 0);
break;
DB_RESBUF_CASEHDR(creation_date)
{
struct tm times;
ISC_TIMESTAMP cdatetime;
char tbuf[100];
memset(tbuf, 0, sizeof(tbuf));
cdatetime.timestamp_date = isc_vax_integer(p, sizeof(ISC_DATE));
cdatetime.timestamp_time = isc_vax_integer(p + sizeof(ISC_DATE), sizeof(ISC_TIME));
isc_decode_timestamp(&cdatetime, ×);
strftime(tbuf, sizeof(tbuf), "%c", ×);
hv_store(RETVAL, keyname, strlen(keyname),
newSVpvn(tbuf, strlen(tbuf)), 0);
break;
}
#endif
default:
break;
}
p = old_p + length;
}
/* don't leak */
safefree(res_buf);
}
OUTPUT:
RETVAL
CLEANUP:
SvREFCNT_dec(RETVAL);
#undef DB_INFOBUF
#undef DB_RESBUF_CASEHDR
#*******************************************************************************
IB_EVENT *
ib_init_event(dbh, ...)
SV *dbh
PREINIT:
char *CLASS = "DBD::InterBase::Event";
int i;
D_imp_dbh(dbh);
CODE:
{
unsigned short cnt = items - 1;
DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Entering init_event(), %d items..\n", cnt));
if (cnt > 0)
{
/* check for max number of events in a single call to event block allocation */
if (cnt > MAX_EVENTS)
croak("Max number of events exceeded.");
RETVAL = (IB_EVENT *) safemalloc(sizeof(IB_EVENT));
if (RETVAL == NULL)
croak("Unable to allocate memory");
/* init members */
RETVAL->dbh = imp_dbh;
RETVAL->event_buffer = NULL;
RETVAL->result_buffer = NULL;
RETVAL->id = 0;
RETVAL->num = cnt;
RETVAL->perl_cb = NULL;
RETVAL->state = INACTIVE;
RETVAL->exec_cb = 0;
RETVAL->names = (char **) safemalloc(sizeof(char*) * MAX_EVENTS);
if (RETVAL->names == NULL)
croak("Unable to allocate memory");
for (i = 0; i < MAX_EVENTS; i++)
{
if (i < cnt) {
/* dangerous!
*(RETVAL->names + i) = SvPV_nolen(ST(i + 1));
*/
RETVAL->names[i] = (char*) safemalloc(sizeof(char) * (SvCUR(ST(i + 1)) + 1));
if (RETVAL->names[i] == NULL)
croak("Unable to allocate memory");
strcpy(RETVAL->names[i], SvPV_nolen(ST(i + 1)));
}
else
*(RETVAL->names + i) = NULL;
}
RETVAL->epb_length = (short) isc_event_block(
&(RETVAL->event_buffer),
&(RETVAL->result_buffer),
cnt,
*(RETVAL->names + 0),
*(RETVAL->names + 1),
*(RETVAL->names + 2),
*(RETVAL->names + 3),
*(RETVAL->names + 4),
*(RETVAL->names + 5),
*(RETVAL->names + 6),
*(RETVAL->names + 7),
*(RETVAL->names + 8),
*(RETVAL->names + 9),
*(RETVAL->names + 10),
*(RETVAL->names + 11),
*(RETVAL->names + 12),
*(RETVAL->names + 13),
*(RETVAL->names + 14));
}
else
croak("Names of the events in interest are not specified");
{
ISC_STATUS status[ISC_STATUS_LENGTH];
ISC_ULONG ecount[15];
isc_wait_for_event(status, &(imp_dbh->db), RETVAL->epb_length, RETVAL->event_buffer,
RETVAL->result_buffer);
if (ib_error_check(dbh, status))
XSRETURN_UNDEF; //croak("error in isc_wait_for_event()");
isc_event_counts(ecount, RETVAL->epb_length, RETVAL->event_buffer,
RETVAL->result_buffer);
}
DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Leaving init_event()\n"));
}
OUTPUT:
RETVAL
int
ib_register_callback(dbh, ev, perl_cb)
SV *dbh
IB_EVENT *ev
SV *perl_cb
PREINIT:
ISC_STATUS status[ISC_STATUS_LENGTH];
D_imp_dbh(dbh);
CODE:
{
DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Entering register_callback()..\n"));
/* save the perl callback function */
if (ev->perl_cb == (SV*)NULL)
ev->perl_cb = newSVsv(perl_cb);
else {
if (_cancel_callback(dbh, ev))
SvSetSV(ev->perl_cb, perl_cb);
else
XSRETURN_UNDEF;
}
/* set up the events */
isc_que_events(
status,
&(imp_dbh->db),
&(ev->id),
ev->epb_length,
ev->event_buffer,
(ISC_EVENT_CALLBACK)_async_callback,
ev);
if (ib_error_check(dbh, status))
XSRETURN_UNDEF;
else
RETVAL = 1;
ev->state = ACTIVE;
}
OUTPUT:
RETVAL
int
ib_cancel_callback(dbh, ev)
SV *dbh
IB_EVENT *ev
PREINIT:
CODE:
RETVAL = _cancel_callback(dbh, ev);
OUTPUT:
RETVAL
HV*
ib_wait_event(dbh, ev)
SV *dbh
IB_EVENT *ev
PREINIT:
int i;
SV **svp;
ISC_STATUS status[ISC_STATUS_LENGTH];
D_imp_dbh(dbh);
CODE:
{
isc_wait_for_event(status, &(imp_dbh->db), ev->epb_length, ev->event_buffer,
ev->result_buffer);
if (ib_error_check(dbh, status))
{
do_error(dbh, 2, "ib_wait_event() error");
XSRETURN_UNDEF;
}
else
{
ISC_ULONG ecount[15];
isc_event_counts(ecount, ev->epb_length, ev->event_buffer,
ev->result_buffer);
RETVAL = newHV();
for (i = 0; i < ev->num; i++)
{
if (ecount[i])
{
DBI_TRACE_imp_xxh(imp_dbh, 2, (DBIc_LOGPIO(imp_dbh), "Event %s caught %ld times.\n", *(ev->names + i), ecount[i]));
svp = hv_store(RETVAL, *(ev->names + i), strlen(*(ev->names + i)),
newSViv(ecount[i]), 0);
if (svp == NULL)
croak("Bad: key '%s' not stored", *(ev->names + i));
}
}
}
}
OUTPUT:
RETVAL
MODULE = DBD::InterBase PACKAGE = DBD::InterBase::Event
PROTOTYPES: DISABLE
void
DESTROY(evh)
IB_EVENT *evh
PREINIT:
int i;
ISC_STATUS status[ISC_STATUS_LENGTH];
CODE:
{
DBI_TRACE_imp_xxh(evh->dbh, 2, (DBIc_LOGPIO(evh->dbh), "Entering DBD::InterBase::Event::DESTROY..\n"));
#ifdef DBI_USE_THREADS
if (PERL_GET_CONTEXT != evh->dbh->context) {
DBI_TRACE_imp_xxh(evh->dbh, 2, (DBIc_LOGPIO(evh->dbh),
"DBD::InterBase::Event::DESTROY ignored because owned by thread %p not current thread %p\n",
evh->dbh->context, (PerlInterpreter *)PERL_GET_CONTEXT)
);
XSRETURN(0);
}
#endif
for (i = 0; i < evh->num; i++)
if (*(evh->names + i))
safefree(*(evh->names + i));
if (evh->names)
safefree(evh->names);
if (evh->perl_cb) {
SvREFCNT_dec(evh->perl_cb);
isc_cancel_events(status, &(evh->dbh->db), &(evh->id));
}
if (evh->event_buffer)
isc_free(evh->event_buffer);
if (evh->result_buffer)
isc_free(evh->result_buffer);
}
MODULE = DBD::InterBase PACKAGE = DBD::InterBase::st
char*
ib_plan(sth)
SV *sth
CODE:
{
D_imp_sth(sth);
ISC_STATUS status[ISC_STATUS_LENGTH];
char plan_info[1];
char plan_buffer[PLAN_BUFFER_LEN];
RETVAL = NULL;
memset(plan_buffer, 0, PLAN_BUFFER_LEN);
plan_info[0] = isc_info_sql_get_plan;
if (isc_dsql_sql_info(status, &(imp_sth->stmt), sizeof(plan_info), plan_info,
sizeof(plan_buffer), plan_buffer))
{
if (ib_error_check(sth, status))
{
ib_cleanup_st_prepare(imp_sth);
XSRETURN_UNDEF;
}
}
if (plan_buffer[0] == isc_info_sql_get_plan) {
short l = (short) isc_vax_integer((char *)plan_buffer + 1, 2);
if ((RETVAL = (char*)safemalloc(sizeof(char) * (l + 2))) == NULL) {
do_error(sth, 2, "Failed to allocate plan buffer");
XSRETURN_UNDEF;
}
sprintf(RETVAL, "%.*s%s", l, plan_buffer + 3, "\n");
//PerlIO_printf(PerlIO_stderr(), "Len: %d, orig len: %d\n", strlen(imp_sth->plan), l);
}
}
OUTPUT:
RETVAL