X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=install%2F5.005%2FDBD-Pg-1.22-fixvercmp%2Fdbdimp.c;fp=install%2F5.005%2FDBD-Pg-1.22-fixvercmp%2Fdbdimp.c;h=55f4ee72658bf2bd45b5b64a9355e36e22f3fcde;hp=0000000000000000000000000000000000000000;hb=ee146c3eada3bdb419ba471dd6df5e889d7dd7e5;hpb=c29fa7acc16efcc86af06077e739fca8b783c3c1 diff --git a/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c new file mode 100644 index 000000000..55f4ee726 --- /dev/null +++ b/install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c @@ -0,0 +1,2024 @@ +/* + $Id: dbdimp.c,v 1.1 2004-04-29 09:21:28 ivan Exp $ + + Copyright (c) 1997,1998,1999,2000 Edmund Mergl + Copyright (c) 2002 Jeffrey W. Baker + Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce + + You may distribute under the terms of either the GNU General Public + License or the Artistic License, as specified in the Perl README file. + +*/ + + +/* + hard-coded OIDs: (here we need the postgresql types) + pg_sql_type() 1042 (bpchar), 1043 (varchar) + ddb_st_fetch() 1042 (bpchar), 16 (bool) + ddb_preparse() 1043 (varchar) + pgtype_bind_ok() +*/ + +#include "Pg.h" + +/* XXX DBI should provide a better version of this */ +#define IS_DBI_HANDLE(h) (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P') + +DBISTATE_DECLARE; + +/* hard-coded array delimiter */ +static char* array_delimiter = ","; + +static void dbd_preparse (imp_sth_t *imp_sth, char *statement); + + +void +dbd_init (dbistate) + dbistate_t *dbistate; +{ + DBIS = dbistate; +} + + +int +dbd_discon_all (drh, imp_drh) + SV *drh; + imp_drh_t *imp_drh; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_discon_all\n"); } + + /* The disconnect_all concept is flawed and needs more work */ + if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) { + sv_setiv(DBIc_ERR(imp_drh), (IV)1); + sv_setpv(DBIc_ERRSTR(imp_drh), + (char*)"disconnect_all not implemented"); + DBIh_EVENT2(drh, ERROR_event, + DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh)); + return FALSE; + } + if (perl_destruct_level) { + perl_destruct_level = 0; + } + return FALSE; +} + + +/* Database specific error handling. */ + +void +pg_error (h, error_num, error_msg) + SV *h; + int error_num; + char *error_msg; +{ + D_imp_xxh(h); + char *err, *src, *dst; + int len = strlen(error_msg); + + err = (char *)malloc(len + 1); + if (!err) { + return; + } + src = error_msg; + dst = err; + + /* copy error message without trailing newlines */ + while (*src != '\0' && *src != '\n') { + *dst++ = *src++; + } + *dst = '\0'; + + sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); /* set err early */ + sv_setpv(DBIc_ERRSTR(imp_xxh), (char*)err); + DBIh_EVENT2(h, ERROR_event, DBIc_ERR(imp_xxh), DBIc_ERRSTR(imp_xxh)); + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "%s error %d recorded: %s\n", err, error_num, SvPV(DBIc_ERRSTR(imp_xxh),na)); } + free(err); +} + +static int +pgtype_bind_ok (dbtype) + int dbtype; +{ + /* basically we support types that can be returned as strings */ + switch(dbtype) { + case 16: /* bool */ + case 17: /* bytea */ + case 18: /* char */ + case 20: /* int8 */ + case 21: /* int2 */ + case 23: /* int4 */ + case 25: /* text */ + case 26: /* oid */ + case 700: /* float4 */ + case 701: /* float8 */ + case 702: /* abstime */ + case 703: /* reltime */ + case 704: /* tinterval */ + case 1042: /* bpchar */ + case 1043: /* varchar */ + case 1082: /* date */ + case 1083: /* time */ + case 1184: /* datetime */ + case 1186: /* timespan */ + case 1296: /* timestamp */ + return 1; + } + return 0; +} + + +/* ================================================================== */ + +int +pg_db_login (dbh, imp_dbh, dbname, uid, pwd) + SV *dbh; + imp_dbh_t *imp_dbh; + char *dbname; + char *uid; + char *pwd; +{ + dTHR; + + char *conn_str; + char *src; + char *dest; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "pg_db_login\n"); } + + /* build connect string */ + /* DBD-Pg syntax: 'dbname=dbname;host=host;port=port' */ + /* pgsql syntax: 'dbname=dbname host=host port=port user=uid password=pwd' */ + + conn_str = (char *)malloc(strlen(dbname) + strlen(uid) + strlen(pwd) + 16 + 1); + if (! conn_str) { + return 0; + } + + src = dbname; + dest = conn_str; + while (*src) { + if (*src != ';') { + *dest++ = *src++; + continue; + } + *dest++ = ' '; + src++; + } + *dest = '\0'; + + if (strlen(uid)) { + strcat(conn_str, " user="); + strcat(conn_str, uid); + } + if (strlen(uid) && strlen(pwd)) { + strcat(conn_str, " password="); + strcat(conn_str, pwd); + } + + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "pg_db_login: conn_str = >%s<\n", conn_str); } + + /* make a connection to the database */ + imp_dbh->conn = PQconnectdb(conn_str); + free(conn_str); + + /* check to see that the backend connection was successfully made */ + if (PQstatus(imp_dbh->conn) != CONNECTION_OK) { + pg_error(dbh, PQstatus(imp_dbh->conn), PQerrorMessage(imp_dbh->conn)); + PQfinish(imp_dbh->conn); + return 0; + } + + imp_dbh->init_commit = 1; /* initialize AutoCommit */ + imp_dbh->pg_auto_escape = 1; /* initialize pg_auto_escape */ + imp_dbh->pg_bool_tf = 0; /* initialize pg_bool_tf */ + + DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */ + DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */ + return 1; +} + + +int +dbd_db_getfd (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + char id; + SV* retsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_getfd\n"); } + + return PQsocket(imp_dbh->conn); +} + +SV * +dbd_db_pg_notifies (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + char id; + PGnotify* notify; + AV* ret; + SV* retsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_pg_notifies\n"); } + + PQconsumeInput(imp_dbh->conn); + + notify = PQnotifies(imp_dbh->conn); + + if (!notify) return &sv_undef; + + ret=newAV(); + + av_push(ret, newSVpv(notify->relname,0) ); + av_push(ret, newSViv(notify->be_pid) ); + + /* Should free notify memory with PQfreemem() */ + + retsv = newRV(sv_2mortal((SV*)ret)); + + return retsv; +} + +int +dbd_db_ping (dbh) + SV *dbh; +{ + char id; + D_imp_dbh(dbh); + PGresult* result; + ExecStatusType status; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_ping\n"); } + + if (NULL != imp_dbh->conn) { + result = PQexec(imp_dbh->conn, " "); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + + if (PGRES_EMPTY_QUERY != status) { + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_commit (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_commit\n"); } + + /* no commit if AutoCommit = on */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) { + return 0; + } + + if (NULL != imp_dbh->conn) { + PGresult* result = 0; + ExecStatusType commitstatus, beginstatus; + + /* execute commit */ + result = PQexec(imp_dbh->conn, "commit"); + commitstatus = result ? PQresultStatus(result) : -1; + PQclear(result); + + /* check result */ + if (commitstatus != PGRES_COMMAND_OK) { + /* Only put the error message in DBH->errstr */ + pg_error(dbh, commitstatus, PQerrorMessage(imp_dbh->conn)); + } + + /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */ + result = PQexec(imp_dbh->conn, "begin"); + beginstatus = result ? PQresultStatus(result) : -1; + PQclear(result); + if (beginstatus != PGRES_COMMAND_OK) { + /* Maybe add some loud barf here? Raising some very high error? */ + pg_error(dbh, beginstatus, "begin failed\n"); + return 0; + } + + /* if the initial COMMIT failed, return 0 now */ + if (commitstatus != PGRES_COMMAND_OK) { + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_rollback (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_rollback\n"); } + + /* no rollback if AutoCommit = on */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) { + return 0; + } + + if (NULL != imp_dbh->conn) { + PGresult* result = 0; + ExecStatusType status; + + /* execute rollback */ + result = PQexec(imp_dbh->conn, "rollback"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + + /* check result */ + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "rollback failed\n"); + return 0; + } + + /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */ + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "begin failed\n"); + return 0; + } + + return 1; + } + + return 0; +} + + +int +dbd_db_disconnect (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect\n"); } + + /* We assume that disconnect will always work */ + /* since most errors imply already disconnected. */ + DBIc_ACTIVE_off(imp_dbh); + + if (NULL != imp_dbh->conn) { + /* rollback if AutoCommit = off */ + if (DBIc_has(imp_dbh, DBIcf_AutoCommit) == FALSE) { + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "rollback"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "rollback failed\n"); + return 0; + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect: AutoCommit=off -> rollback\n"); } + } + + PQfinish(imp_dbh->conn); + + imp_dbh->conn = NULL; + } + + /* We don't free imp_dbh since a reference still exists */ + /* The DESTROY method is the only one to 'free' memory. */ + /* Note that statement objects may still exists for this dbh! */ + return 1; +} + + +void +dbd_db_destroy (dbh, imp_dbh) + SV *dbh; + imp_dbh_t *imp_dbh; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_destroy\n"); } + + if (DBIc_ACTIVE(imp_dbh)) { + dbd_db_disconnect(dbh, imp_dbh); + } + + /* Nothing in imp_dbh to be freed */ + DBIc_IMPSET_off(imp_dbh); +} + + +int +dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; + SV *valuesv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + int newval = SvTRUE(valuesv); + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_STORE\n"); } + + if (kl==10 && strEQ(key, "AutoCommit")) { + int oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit); + DBIc_set(imp_dbh, DBIcf_AutoCommit, newval); + if (oldval == FALSE && newval != FALSE && imp_dbh->init_commit) { + /* do nothing, fall through */ + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: initialize AutoCommit to on\n"); } + } else if (oldval == FALSE && newval != FALSE) { + if (NULL != imp_dbh->conn) { + /* commit any outstanding changes */ + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "commit"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "commit failed\n"); + return 0; + } + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to on: commit\n"); } + } else if ((oldval != FALSE && newval == FALSE) || (oldval == FALSE && newval == FALSE && imp_dbh->init_commit)) { + if (NULL != imp_dbh->conn) { + /* start new transaction */ + PGresult* result = 0; + ExecStatusType status; + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(dbh, status, "begin failed\n"); + return 0; + } + } + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to off: begin\n"); } + } + /* only needed once */ + imp_dbh->init_commit = 0; + return 1; + } else if (kl==14 && strEQ(key, "pg_auto_escape")) { + imp_dbh->pg_auto_escape = newval; + } else if (kl==10 && strEQ(key, "pg_bool_tf")) { + imp_dbh->pg_bool_tf = newval; +#ifdef SvUTF8_off + } else if (kl==14 && strEQ(key, "pg_enable_utf8")) { + imp_dbh->pg_enable_utf8 = newval; +#endif + } else { + return 0; + } +} + + +SV * +dbd_db_FETCH_attrib (dbh, imp_dbh, keysv) + SV *dbh; + imp_dbh_t *imp_dbh; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + SV *retsv = Nullsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_FETCH\n"); } + + if (kl==10 && strEQ(key, "AutoCommit")) { + retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit)); + } else if (kl==14 && strEQ(key, "pg_auto_escape")) { + retsv = newSViv((IV)imp_dbh->pg_auto_escape); + } else if (kl==10 && strEQ(key, "pg_bool_tf")) { + retsv = newSViv((IV)imp_dbh->pg_bool_tf); +#ifdef SvUTF8_off + } else if (kl==14 && strEQ(key, "pg_enable_utf8")) { + retsv = newSViv((IV)imp_dbh->pg_enable_utf8); +#endif + } else if (kl==11 && strEQ(key, "pg_INV_READ")) { + retsv = newSViv((IV)INV_READ); + } else if (kl==12 && strEQ(key, "pg_INV_WRITE")) { + retsv = newSViv((IV)INV_WRITE); + } + + if (!retsv) { + return Nullsv; + } + if (retsv == &sv_yes || retsv == &sv_no) { + return retsv; /* no need to mortalize yes or no */ + } + return sv_2mortal(retsv); +} + + +/* driver specific functins */ + + +int +pg_db_lo_open (dbh, lobjId, mode) + SV *dbh; + unsigned int lobjId; + int mode; +{ + D_imp_dbh(dbh); + return lo_open(imp_dbh->conn, lobjId, mode); +} + + +int +pg_db_lo_close (dbh, fd) + SV *dbh; + int fd; +{ + D_imp_dbh(dbh); + return lo_close(imp_dbh->conn, fd); +} + + +int +pg_db_lo_read (dbh, fd, buf, len) + SV *dbh; + int fd; + char *buf; + int len; +{ + D_imp_dbh(dbh); + return lo_read(imp_dbh->conn, fd, buf, len); +} + + +int +pg_db_lo_write (dbh, fd, buf, len) + SV *dbh; + int fd; + char *buf; + int len; +{ + D_imp_dbh(dbh); + return lo_write(imp_dbh->conn, fd, buf, len); +} + + +int +pg_db_lo_lseek (dbh, fd, offset, whence) + SV *dbh; + int fd; + int offset; + int whence; +{ + D_imp_dbh(dbh); + return lo_lseek(imp_dbh->conn, fd, offset, whence); +} + + +unsigned int +pg_db_lo_creat (dbh, mode) + SV *dbh; + int mode; +{ + D_imp_dbh(dbh); + return lo_creat(imp_dbh->conn, mode); +} + + +int +pg_db_lo_tell (dbh, fd) + SV *dbh; + int fd; +{ + D_imp_dbh(dbh); + return lo_tell(imp_dbh->conn, fd); +} + + +int +pg_db_lo_unlink (dbh, lobjId) + SV *dbh; + unsigned int lobjId; +{ + D_imp_dbh(dbh); + return lo_unlink(imp_dbh->conn, lobjId); +} + + +unsigned int +pg_db_lo_import (dbh, filename) + SV *dbh; + char *filename; +{ + D_imp_dbh(dbh); + return lo_import(imp_dbh->conn, filename); +} + + +int +pg_db_lo_export (dbh, lobjId, filename) + SV *dbh; + unsigned int lobjId; + char *filename; +{ + D_imp_dbh(dbh); + return lo_export(imp_dbh->conn, lobjId, filename); +} + + +int +pg_db_putline (dbh, buffer) + SV *dbh; + char *buffer; +{ + D_imp_dbh(dbh); + return PQputline(imp_dbh->conn, buffer); +} + + +int +pg_db_getline (dbh, buffer, length) + SV *dbh; + char *buffer; + int length; +{ + D_imp_dbh(dbh); + return PQgetline(imp_dbh->conn, buffer, length); +} + + +int +pg_db_endcopy (dbh) + SV *dbh; +{ + D_imp_dbh(dbh); + return PQendcopy(imp_dbh->conn); +} + + +/* ================================================================== */ + + +int +dbd_st_prepare (sth, imp_sth, statement, attribs) + SV *sth; + imp_sth_t *imp_sth; + char *statement; + SV *attribs; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_prepare: statement = >%s<\n", statement); } + + /* scan statement for '?', ':1' and/or ':foo' style placeholders */ + dbd_preparse(imp_sth, statement); + + /* initialize new statement handle */ + imp_sth->result = 0; + imp_sth->cur_tuple = 0; + + DBIc_IMPSET_on(imp_sth); + return 1; +} + + +static void +dbd_preparse (imp_sth, statement) + imp_sth_t *imp_sth; + char *statement; +{ + bool in_literal = FALSE; + char in_comment = '\0'; + char *src, *start, *dest; + phs_t phs_tpl; + SV *phs_sv; + int idx=0; + char *style="", *laststyle=Nullch; + STRLEN namelen; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_preparse: statement = >%s<\n", statement); } + + /* allocate room for copy of statement with spare capacity */ + /* for editing '?' or ':1' into ':p1'. */ + /* */ + /* Note: the calculated length used here for the safemalloc */ + /* isn't related in any way to the actual worst case length */ + /* of the translated statement, but allowing for 3 times */ + /* the length of the original statement should be safe... */ + imp_sth->statement = (char*)safemalloc(strlen(statement) * 3 + 1); + + /* initialise phs ready to be cloned per placeholder */ + memset(&phs_tpl, 0, sizeof(phs_tpl)); + phs_tpl.ftype = 1043; /* VARCHAR */ + + src = statement; + dest = imp_sth->statement; + while(*src) { + + if (in_comment) { + /* SQL-style and C++-style */ + if ((in_comment == '-' || in_comment == '/') && *src == '\n') { + in_comment = '\0'; + } + /* C-style */ + else if (in_comment == '*' && *src == '*' && *(src+1) == '/') { + *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */ + in_comment = '\0'; + } + *dest++ = *src++; + continue; + } + + if (in_literal) { + /* check if literal ends but keep quotes in literal */ + if (*src == in_literal) { + int bs=0; + char *str; + str = src-1; + while (*(str-bs) == '\\') + bs++; + if (!(bs & 1)) + in_literal = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments: SQL-style or C++-style or C-style */ + if ((*src == '-' && *(src+1) == '-') || + (*src == '/' && *(src+1) == '/') || + (*src == '/' && *(src+1) == '*')) + { + in_comment = *(src+1); + /* We know *src & the next char are to be copied, so do */ + /* it. In the case of C-style comments, it happens to */ + /* help us avoid slash-asterisk-slash oddities. */ + *dest++ = *src++; + *dest++ = *src++; + continue; + } + + /* check if no placeholders */ + if (*src != ':' && *src != '?') { + if (*src == '\'' || *src == '"') { + in_literal = *src; + } + *dest++ = *src++; + continue; + } + + /* check for cast operator */ + if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) { + *dest++ = *src++; + continue; + } + + /* only here for : or ? outside of a comment or literal and no cast */ + + start = dest; /* save name inc colon */ + *dest++ = *src++; + if (*start == '?') { /* X/Open standard */ + sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */ + 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++ = *src++; + } + style = ":foo"; + } else { /* perhaps ':=' PL/SQL construct */ + continue; + } + *dest = '\0'; /* handy for debugging */ + namelen = (dest-start); + if (laststyle && style != laststyle) { + croak("Can't mix placeholder styles (%s/%s)",style,laststyle); + } + laststyle = style; + if (imp_sth->all_params_hv == NULL) { + imp_sth->all_params_hv = newHV(); + } + phs_tpl.sv = &sv_undef; + phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1); + hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0); + strcpy( ((phs_t*)(void*)SvPVX(phs_sv))->name, start); + } + *dest = '\0'; + if (imp_sth->all_params_hv) { + DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv); + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n", (int)DBIc_NUM_PARAMS(imp_sth)); } + } +} + + +/* if it LOOKS like a string, this function will determine whether the type needs to be surrounded in single quotes */ +static int pg_sql_needquote (sql_type) + int sql_type; +{ + if (sql_type > 1000 || sql_type == 17 || sql_type == 25 ) { + return 1; + } + return 0; +} + + + +static int +pg_sql_type (imp_sth, name, sql_type) + imp_sth_t *imp_sth; + char *name; + int sql_type; +{ + switch (sql_type) { + case SQL_CHAR: + return 1042; /* bpchar */ + case SQL_NUMERIC: + return 700; /* float4 */ + case SQL_DECIMAL: + return 700; /* float4 */ + case SQL_INTEGER: + return 23; /* int4 */ + case SQL_SMALLINT: + return 21; /* int2 */ + case SQL_FLOAT: + return 700; /* float4 */ + case SQL_REAL: + return 701; /* float8 */ + case SQL_DOUBLE: + return 20; /* int8 */ + case SQL_VARCHAR: + return 1043; /* varchar */ + case SQL_BINARY: + return 17; /* bytea */ + default: + if (DBIc_WARN(imp_sth) && imp_sth && name) { + warn("SQL type %d for '%s' is not fully supported, bound as VARCHAR instead", + sql_type, name); + } + return pg_sql_type(imp_sth, name, SQL_VARCHAR); + } +} + +static int +sql_pg_type (imp_sth, name, sql_type) + imp_sth_t *imp_sth; + char *name; + int sql_type; +{ + if (dbis->debug >= 1) { + PerlIO_printf(DBILOGFP, "sql_pg_type name '%s' type '%d'\n", name, sql_type ); + } + + switch (sql_type) { + case 17: /* bytea */ + return SQL_BINARY; + case 20: /* int8 */ + return SQL_DOUBLE; + case 21: /* int2 */ + return SQL_SMALLINT; + case 23: /* int4 */ + return SQL_INTEGER; + case 700: /* float4 */ + return SQL_NUMERIC; + case 701: /* float8 */ + return SQL_REAL; + case 1042: /* bpchar */ + return SQL_CHAR; + case 1043: /* varchar */ + return SQL_VARCHAR; + case 1082: /* date */ + return SQL_DATE; + case 1083: /* time */ + return SQL_TIME; + case 1296: /* date */ + return SQL_TIMESTAMP; + + default: + return sql_type; + } +} + + +static int +dbd_rebind_ph (sth, imp_sth, phs) + SV *sth; + imp_sth_t *imp_sth; + phs_t *phs; +{ + STRLEN value_len; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rebind\n"); } + + /* convert to a string ASAP */ + if (!SvPOK(phs->sv) && SvOK(phs->sv)) { + sv_2pv(phs->sv, &na); + } + + if (dbis->debug >= 2) { + char *val = neatsvpv(phs->sv,0); + PerlIO_printf(DBILOGFP, " bind %s <== %.1000s (", phs->name, val); + if (SvOK(phs->sv)) { + PerlIO_printf(DBILOGFP, "size %ld/%ld/%ld, ", (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen); + } else { + PerlIO_printf(DBILOGFP, "NULL, "); + } + PerlIO_printf(DBILOGFP, "ptype %d, otype %d%s)\n", (int)SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : ""); + } + + /* At the moment we always do sv_setsv() and rebind. */ + /* Later we may optimise this so that more often we can */ + /* just copy the value & length over and not rebind. */ + + if (phs->is_inout) { /* XXX */ + if (SvREADONLY(phs->sv)) { + croak(no_modify); + } + /* phs->sv _is_ the real live variable, it may 'mutate' later */ + /* pre-upgrade high to reduce risk of SvPVX realloc/move */ + (void)SvUPGRADE(phs->sv, SVt_PVNV); + /* ensure room for result, 28 is magic number (see sv_2pv) */ + SvGROW(phs->sv, (phs->maxlen < 28) ? 28 : phs->maxlen+1); + } + else { + /* phs->sv is copy of real variable, upgrade to at least string */ + (void)SvUPGRADE(phs->sv, SVt_PV); + } + + /* At this point phs->sv must be at least a PV with a valid buffer, */ + /* even if it's undef (null) */ + /* Here we set phs->progv, phs->indp, and value_len. */ + if (SvOK(phs->sv)) { + phs->progv = SvPV(phs->sv, value_len); + phs->indp = 0; + } + else { /* it's null but point to buffer in case it's an out var */ + phs->progv = SvPVX(phs->sv); + phs->indp = -1; + value_len = 0; + } + phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */ + phs->maxlen = SvLEN(phs->sv)-1; /* avail buffer space */ + if (phs->maxlen < 0) { /* can happen with nulls */ + phs->maxlen = 0; + } + + phs->alen = value_len + phs->alen_incnull; + + imp_sth->all_params_len += SvOK(phs->sv) ? phs->alen : 4; /* NULL */ + + if (dbis->debug >= 3) { + PerlIO_printf(DBILOGFP, " bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n", + phs->name, + (int)(phs->alen>SvIV(DBIS->neatsvpvlen) ? SvIV(DBIS->neatsvpvlen) : phs->alen), + (phs->progv) ? phs->progv : "", + (long)phs->alen, (long)phs->maxlen, phs->ftype, phs->indp); + } + + return 1; +} + + +void dereference(value) +SV** value; +{ + AV* buf; + SV* val; + char *src; + int is_ref; + STRLEN len; + + if (SvTYPE(SvRV(*value)) != SVt_PVAV) + croak("Not an array reference (%s)", neatsvpv(*value,0)); + + buf = (AV *) SvRV(*value); + sv_setpv(*value, "{"); + while ( SvOK(val = av_shift(buf)) ) { + is_ref = SvROK(val); + if (is_ref) + dereference(&val); + else + sv_catpv(*value, "\""); + /* Quote */ + src = SvPV(val, len); + while (len--) { + if (!is_ref && *src == '\"') + sv_catpv(*value, "\\"); + sv_catpvn(*value, src++, 1); + } + /* End of quote */ + if (!is_ref) + sv_catpv(*value, "\""); + if (av_len(buf) > -1) + sv_catpv(*value, array_delimiter); + } + sv_catpv(*value, "}"); + av_clear(buf); +} + +int +dbd_bind_ph (sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen) + SV *sth; + imp_sth_t *imp_sth; + SV *ph_namesv; + SV *newvalue; + IV sql_type; + SV *attribs; + int is_inout; + IV maxlen; +{ + SV **phs_svp; + STRLEN name_len; + char *name; + char namebuf[30]; + phs_t *phs; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_bind_ph\n"); } + + /* check if placeholder was passed as a number */ + + if (SvGMAGICAL(ph_namesv)) { /* eg if from tainted expression */ + mg_get(ph_namesv); + } + if (!SvNIOKp(ph_namesv)) { + name = SvPV(ph_namesv, name_len); + } + if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) { + sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv)); + name = namebuf; + name_len = strlen(name); + } + assert(name != Nullch); + + if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */ + croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0)); + } + if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) { + /* dbi handle allowed for cursor variables */ + dereference(&newvalue); + } + if (SvTYPE(newvalue) == SVt_PVLV && is_inout) { /* may allow later */ + croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)"); + } + + 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%lx, maxlen %ld", (long)newvalue, (long)maxlen); + } + if (attribs) { + PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0)); + } + PerlIO_printf(DBILOGFP, ")\n"); + } + + phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0); + if (phs_svp == NULL) { + croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0)); + } + phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */ + + if (phs->sv == &sv_undef) { /* first bind for this placeholder */ + phs->ftype = 1043; /* our default type VARCHAR */ + phs->is_inout = is_inout; + if (is_inout) { + /* phs->sv assigned in the code below */ + ++imp_sth->has_inout_params; + /* build array of phs's so we can deal with out vars fast */ + if (!imp_sth->out_params_av) { + imp_sth->out_params_av = newAV(); + } + av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp)); + } + + if (attribs) { /* only look for pg_type on first bind of var */ + SV **svp; + /* Setup / Clear attributes as defined by attribs. */ + /* XXX If attribs is EMPTY then reset attribs to default? */ + if ( (svp = hv_fetch((HV*)SvRV(attribs), "pg_type", 7, 0)) != NULL) { + int pg_type = SvIV(*svp); + if (!pgtype_bind_ok(pg_type)) { + croak("Can't bind %s, pg_type %d not supported by DBD::Pg", phs->name, pg_type); + } + if (sql_type) { + croak("Can't specify both TYPE (%d) and pg_type (%d) for %s", sql_type, pg_type, phs->name); + } + phs->ftype = pg_type; + } + } + if (sql_type) { + /* SQL_BINARY (-2) is deprecated. */ + if (sql_type == -2 && DBIc_WARN(imp_sth)) { + warn("Use of SQL type SQL_BINARY (%d) is deprecated. Use { pg_type => DBD::Pg::PG_BYTEA } instead.", sql_type); + } + phs->ftype = pg_sql_type(imp_sth, phs->name, sql_type); + } + } /* was first bind for this placeholder */ + + /* check later rebinds for any changes */ + else if (is_inout || phs->is_inout) { + croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)", phs->name, phs->is_inout , is_inout); + } + else if (sql_type && phs->ftype != pg_sql_type(imp_sth, phs->name, sql_type)) { + croak("Can't change TYPE of param %s to %d after initial bind", phs->name, sql_type); + } + + phs->maxlen = maxlen; /* 0 if not inout */ + + if (!is_inout) { /* normal bind to take a (new) copy of current value */ + if (phs->sv == &sv_undef) { /* (first time bind) */ + phs->sv = newSV(0); + } + sv_setsv(phs->sv, newvalue); + } else if (newvalue != phs->sv) { + if (phs->sv) { + SvREFCNT_dec(phs->sv); + } + phs->sv = SvREFCNT_inc(newvalue); /* point to live var */ + } + + return dbd_rebind_ph(sth, imp_sth, phs); +} + + +int +dbd_st_execute (sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */ + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + + D_imp_dbh_from_sth; + ExecStatusType status = -1; + char *cmdStatus; + char *cmdTuples; + char *statement; + int ret = -2; + int num_fields; + int i; + STRLEN len; + bool in_literal = FALSE; + char in_comment = '\0'; + char *src; + char *dest; + char *val; + char namebuf[30]; + phs_t *phs; + SV **svp; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_execute\n"); } + + /* + here we get the statement from the statement handle where + it has been stored when creating a blank sth during prepare + svp = hv_fetch((HV *)SvRV(sth), "Statement", 9, FALSE); + statement = SvPV(*svp, na); + */ + + if (NULL == imp_dbh->conn) { + pg_error(sth, -1, "execute on disconnected handle"); + return -2; + } + + statement = imp_sth->statement; + if (! statement) { + /* are we prepared ? */ + pg_error(sth, -1, "statement not prepared\n"); + return -2; + } + + /* do we have input parameters ? */ + if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) { + /* + we have to allocate some additional memory for possible escaping + quotes and backslashes: + max_len = length of statement + + total length of all params allowing for worst case all + characters binary-escaped (\\xxx) + + null terminator + Note: parameters look like :p1 at this point, so there's no + need to explicitly allow for surrounding quotes because '' is + shorter than :p1 + */ + int max_len = strlen(imp_sth->statement) + imp_sth->all_params_len * 5 + 1; + statement = (char*)safemalloc( max_len ); + dest = statement; + src = imp_sth->statement; + /* scan statement for ':p1' style placeholders */ + while(*src) { + + if (in_comment) { + /* SQL-style and C++-style */ + if ((in_comment == '-' || in_comment == '/') && *src == '\n') { + in_comment = '\0'; + } + /* C-style */ + else if (in_comment == '*' && *src == '*' && *(src+1) == '/') { + *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */ + in_comment = '\0'; + } + *dest++ = *src++; + continue; + } + + if (in_literal) { + /* check if literal ends but keep quotes in literal */ + if (*src == in_literal) { + int bs=0; + char *str; + str = src-1; + while (*(str-bs) == '\\') + bs++; + if (!(bs & 1)) + in_literal = 0; + } + *dest++ = *src++; + continue; + } + + /* Look for comments: SQL-style or C++-style or C-style */ + if ((*src == '-' && *(src+1) == '-') || + (*src == '/' && *(src+1) == '/') || + (*src == '/' && *(src+1) == '*')) + { + in_comment = *(src+1); + /* We know *src & the next char are to be copied, so do */ + /* it. In the case of C-style comments, it happens to */ + /* help us avoid slash-asterisk-slash oddities. */ + *dest++ = *src++; + *dest++ = *src++; + continue; + } + + /* check if no placeholders */ + if (*src != ':' && *src != '?') { + if (*src == '\'' || *src == '"') { + in_literal = *src; + } + *dest++ = *src++; + continue; + } + + /* check for cast operator */ + if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) { + *dest++ = *src++; + continue; + } + + + i = 0; + namebuf[i++] = *src++; /* ':' */ + namebuf[i++] = *src++; /* 'p' */ + + while (isDIGIT(*src) && i < (sizeof(namebuf)-1) ) { + namebuf[i++] = *src++; + } + if ( i == (sizeof(namebuf) - 1)) { + pg_error(sth, -1, "namebuf buffer overrun\n"); + return -2; + } + namebuf[i] = '\0'; + svp = hv_fetch(imp_sth->all_params_hv, namebuf, i, 0); + if (svp == NULL) { + pg_error(sth, -1, "parameter unknown\n"); + return -2; + } + /* get attribute */ + phs = (phs_t*)(void*)SvPVX(*svp); + /* replace undef with NULL */ + if(!SvOK(phs->sv)) { + val = "NULL"; + len = 4; + } else { + val = SvPV(phs->sv, len); + } + /* quote string attribute */ + if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */ + *dest++ = '\''; + } + while (len--) { + if (imp_dbh->pg_auto_escape) { + /* if the parameter was bound as PG_BYTEA, escape nonprintables */ + if (phs->ftype == 17 && !isPRINT(*val)) { /* escape null character */ + dest+=snprintf(dest, (statement + max_len) - dest, "\\\\%03o", *((unsigned char *)val)); + if (dest > statement + max_len) { + pg_error(sth, -1, "statement buffer overrun\n"); + return -2; + } + val++; + continue; /* do not copy the null */ + } + /* escape quote */ + if (*val == '\'') { + *dest++ = '\''; + } + /* escape backslash */ + if (*val == '\\') { + if (phs->ftype == 17) { /* four backslashes. really. */ + *dest++ = '\\'; + *dest++ = '\\'; + *dest++ = '\\'; + } else { + *dest++ = '\\'; + } + } + } + /* copy attribute to statement */ + *dest++ = *val++; + } + /* quote string attribute */ + if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */ + *dest++ = '\''; + } + } + *dest = '\0'; + } + + if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_st_execute: statement = >%s<\n", statement); } + + /* clear old result (if any) */ + if (imp_sth->result) { + PQclear(imp_sth->result); + } + + /* execute statement */ + imp_sth->result = PQexec(imp_dbh->conn, statement); + + /* free statement string in case of input parameters */ + if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) { + Safefree(statement); + } + + /* check status */ + status = imp_sth->result ? PQresultStatus(imp_sth->result) : -1; + cmdStatus = imp_sth->result ? (char *)PQcmdStatus(imp_sth->result) : ""; + cmdTuples = imp_sth->result ? (char *)PQcmdTuples(imp_sth->result) : ""; + + if (PGRES_TUPLES_OK == status) { + /* select statement */ + num_fields = PQnfields(imp_sth->result); + imp_sth->cur_tuple = 0; + DBIc_NUM_FIELDS(imp_sth) = num_fields; + DBIc_ACTIVE_on(imp_sth); + ret = PQntuples(imp_sth->result); + } else if (PGRES_COMMAND_OK == status) { + /* non-select statement */ + if (! strncmp(cmdStatus, "DELETE", 6) || ! strncmp(cmdStatus, "INSERT", 6) || ! strncmp(cmdStatus, "UPDATE", 6)) { + ret = atoi(cmdTuples); + } else { + ret = -1; + } + } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) { + /* Copy Out/In data transfer in progress */ + ret = -1; + } else { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + ret = -2; + } + + /* store the number of affected rows */ + imp_sth->rows = ret; + + return ret; +} + + +int +is_high_bit_set(val) + char *val; +{ + while (*val++) + if (*val & 0x80) return 1; + return 0; +} + +AV * +dbd_st_fetch (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + D_imp_dbh_from_sth; + int num_fields; + int i; + AV *av; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_fetch\n"); } + + /* Check that execute() was executed sucessfully */ + if ( !DBIc_ACTIVE(imp_sth) ) { + pg_error(sth, 1, "no statement executing\n"); + + return Nullav; + } + + if ( imp_sth->cur_tuple == PQntuples(imp_sth->result) ) { + imp_sth->cur_tuple = 0; + DBIc_ACTIVE_off(imp_sth); + return Nullav; /* we reached the last tuple */ + } + + av = DBIS->get_fbav(imp_sth); + num_fields = AvFILL(av)+1; + + for(i = 0; i < num_fields; ++i) { + + SV *sv = AvARRAY(av)[i]; + if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)) { + sv_setsv(sv, &sv_undef); + } else { + char *val = (char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i); + int val_len = strlen(val); + int type = PQftype(imp_sth->result, i); /* hopefully these hard coded values will not change */ + if (16 == type && ! imp_dbh->pg_bool_tf) { + *val = (*val == 'f') ? '0' : '1'; /* bool: translate postgres into perl */ + } + if (17 == type) { /* decode \001 -> chr(1), etc, in-place */ + char *p = val; /* points to next available pos */ + char *s = val; /* points to current scanning pos */ + int c1,c2,c3; + while (*s) { + if (*s == '\\') { + if (*(s+1) == '\\') { /* double backslash */ + *p++ = '\\'; + s += 2; + continue; + } + else if ( isdigit(c1=(*(s+1))) && + isdigit(c2=(*(s+2))) && + isdigit(c3=(*(s+3))) ) { + *p++ = (c1 - '0') * 64 + (c2 - '0') * 8 + (c3 - '0'); + s += 4; + continue; + } + } + *p++ = *s++; + } + val_len = (p - val); + } + else if (1042 == type && DBIc_has(imp_sth,DBIcf_ChopBlanks)) { + char *str = val; + while((val_len > 0) && (str[val_len-1] == ' ')) { + val_len--; + } + val[val_len] = '\0'; + } + sv_setpvn(sv, val, val_len); +#ifdef SvUTF8_off + if (imp_dbh->pg_enable_utf8) { + SvUTF8_off(sv); + /* XXX Is this all the character data types? */ + if (18 == type || 25 == type || 1042 ==type || 1043 == type) { + if (is_high_bit_set(val) && is_utf8_string(val, val_len)) + SvUTF8_on(sv); + } + } +#endif + } + } + + imp_sth->cur_tuple += 1; + + return av; +} + + +int +dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset) + SV *sth; + imp_sth_t *imp_sth; + int lobjId; + long offset; + long len; + SV *destrv; + long destoffset; +{ + D_imp_dbh_from_sth; + int ret, lobj_fd, nbytes, nread; + PGresult* result; + ExecStatusType status; + SV *bufsv; + char *tmp; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_blob_read\n"); } + /* safety check */ + if (lobjId <= 0) { + pg_error(sth, -1, "dbd_st_blob_read: lobjId <= 0"); + return 0; + } + if (offset < 0) { + pg_error(sth, -1, "dbd_st_blob_read: offset < 0"); + return 0; + } + if (len < 0) { + pg_error(sth, -1, "dbd_st_blob_read: len < 0"); + return 0; + } + if (! SvROK(destrv)) { + pg_error(sth, -1, "dbd_st_blob_read: destrv not a reference"); + return 0; + } + if (destoffset < 0) { + pg_error(sth, -1, "dbd_st_blob_read: destoffset < 0"); + return 0; + } + + /* dereference destination and ensure it's writable string */ + bufsv = SvRV(destrv); + if (! destoffset) { + sv_setpvn(bufsv, "", 0); + } + + /* execute begin + result = PQexec(imp_dbh->conn, "begin"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + return 0; + } + */ + + /* open large object */ + lobj_fd = lo_open(imp_dbh->conn, lobjId, INV_READ); + if (lobj_fd < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + + /* seek on large object */ + if (offset > 0) { + ret = lo_lseek(imp_dbh->conn, lobj_fd, offset, SEEK_SET); + if (ret < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + } + + /* read from large object */ + nread = 0; + SvGROW(bufsv, destoffset + nread + BUFSIZ + 1); + tmp = (SvPVX(bufsv)) + destoffset + nread; + while ((nbytes = lo_read(imp_dbh->conn, lobj_fd, tmp, BUFSIZ)) > 0) { + nread += nbytes; + /* break if user wants only a specified chunk */ + if (len > 0 && nread > len) { + nread = len; + break; + } + SvGROW(bufsv, destoffset + nread + BUFSIZ + 1); + tmp = (SvPVX(bufsv)) + destoffset + nread; + } + + /* terminate string */ + SvCUR_set(bufsv, destoffset + nread); + *SvEND(bufsv) = '\0'; + + /* close large object */ + ret = lo_close(imp_dbh->conn, lobj_fd); + if (ret < 0) { + pg_error(sth, -1, PQerrorMessage(imp_dbh->conn)); + return 0; + } + + /* execute end + result = PQexec(imp_dbh->conn, "end"); + status = result ? PQresultStatus(result) : -1; + PQclear(result); + if (status != PGRES_COMMAND_OK) { + pg_error(sth, status, PQerrorMessage(imp_dbh->conn)); + return 0; + } + */ + + return nread; +} + + +int +dbd_st_rows (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rows\n"); } + + return imp_sth->rows; +} + + +int +dbd_st_finish (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + dTHR; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_finish\n"); } + + if (DBIc_ACTIVE(imp_sth) && imp_sth->result) { + PQclear(imp_sth->result); + imp_sth->result = 0; + imp_sth->rows = 0; + } + + DBIc_ACTIVE_off(imp_sth); + return 1; +} + + +void +dbd_st_destroy (sth, imp_sth) + SV *sth; + imp_sth_t *imp_sth; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_destroy\n"); } + + /* Free off contents of imp_sth */ + + Safefree(imp_sth->statement); + if (imp_sth->result) { + PQclear(imp_sth->result); + imp_sth->result = 0; + } + + if (imp_sth->out_params_av) + sv_free((SV*)imp_sth->out_params_av); + + if (imp_sth->all_params_hv) { + HV *hv = imp_sth->all_params_hv; + SV *sv; + char *key; + I32 retlen; + hv_iterinit(hv); + while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) { + if (sv != &sv_undef) { + phs_t *phs_tpl = (phs_t*)(void*)SvPVX(sv); + sv_free(phs_tpl->sv); + } + } + sv_free((SV*)imp_sth->all_params_hv); + } + + DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */ +} + + +int +dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; + SV *valuesv; +{ + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_STORE\n"); } + + return FALSE; +} + + +SV * +dbd_st_FETCH_attrib (sth, imp_sth, keysv) + SV *sth; + imp_sth_t *imp_sth; + SV *keysv; +{ + STRLEN kl; + char *key = SvPV(keysv,kl); + int i, sz; + SV *retsv = Nullsv; + + if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_FETCH\n"); } + + if (! imp_sth->result) { + return Nullsv; + } + + i = DBIc_NUM_FIELDS(imp_sth); + + if (kl == 4 && strEQ(key, "NAME")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0)); + } + } else if ( kl== 4 && strEQ(key, "TYPE")) { + /* Need to convert the Pg type to ANSI/SQL type. */ + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(sql_pg_type( imp_sth, + PQfname(imp_sth->result, i), + PQftype(imp_sth->result, i)))); + } + } else if (kl==9 && strEQ(key, "PRECISION")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + sz = PQfsize(imp_sth->result, i); + av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef); + } + } else if (kl==5 && strEQ(key, "SCALE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, &sv_undef); + } + } else if (kl==8 && strEQ(key, "NULLABLE")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(2)); + } + } else if (kl==10 && strEQ(key, "CursorName")) { + retsv = &sv_undef; + } else if (kl==11 && strEQ(key, "RowsInCache")) { + retsv = &sv_undef; + } else if (kl==7 && strEQ(key, "pg_size")) { + AV *av = newAV(); + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + av_store(av, i, newSViv(PQfsize(imp_sth->result, i))); + } + } else if (kl==7 && strEQ(key, "pg_type")) { + AV *av = newAV(); + char *type_nam; + retsv = newRV(sv_2mortal((SV*)av)); + while(--i >= 0) { + switch (PQftype(imp_sth->result, i)) { + case 16: + type_nam = "bool"; + break; + case 17: + type_nam = "bytea"; + break; + case 18: + type_nam = "char"; + break; + case 19: + type_nam = "name"; + break; + case 20: + type_nam = "int8"; + break; + case 21: + type_nam = "int2"; + break; + case 22: + type_nam = "int28"; + break; + case 23: + type_nam = "int4"; + break; + case 24: + type_nam = "regproc"; + break; + case 25: + type_nam = "text"; + break; + case 26: + type_nam = "oid"; + break; + case 27: + type_nam = "tid"; + break; + case 28: + type_nam = "xid"; + break; + case 29: + type_nam = "cid"; + break; + case 30: + type_nam = "oid8"; + break; + case 32: + type_nam = "SET"; + break; + case 210: + type_nam = "smgr"; + break; + case 600: + type_nam = "point"; + break; + case 601: + type_nam = "lseg"; + break; + case 602: + type_nam = "path"; + break; + case 603: + type_nam = "box"; + break; + case 604: + type_nam = "polygon"; + break; + case 605: + type_nam = "filename"; + break; + case 628: + type_nam = "line"; + break; + case 629: + type_nam = "_line"; + break; + case 700: + type_nam = "float4"; + break; + case 701: + type_nam = "float8"; + break; + case 702: + type_nam = "abstime"; + break; + case 703: + type_nam = "reltime"; + break; + case 704: + type_nam = "tinterval"; + break; + case 705: + type_nam = "unknown"; + break; + case 718: + type_nam = "circle"; + break; + case 719: + type_nam = "_circle"; + break; + case 790: + type_nam = "money"; + break; + case 791: + type_nam = "_money"; + break; + case 810: + type_nam = "oidint2"; + break; + case 910: + type_nam = "oidint4"; + break; + case 911: + type_nam = "oidname"; + break; + case 1000: + type_nam = "_bool"; + break; + case 1001: + type_nam = "_bytea"; + break; + case 1002: + type_nam = "_char"; + break; + case 1003: + type_nam = "_name"; + break; + case 1005: + type_nam = "_int2"; + break; + case 1006: + type_nam = "_int28"; + break; + case 1007: + type_nam = "_int4"; + break; + case 1008: + type_nam = "_regproc"; + break; + case 1009: + type_nam = "_text"; + break; + case 1028: + type_nam = "_oid"; + break; + case 1010: + type_nam = "_tid"; + break; + case 1011: + type_nam = "_xid"; + break; + case 1012: + type_nam = "_cid"; + break; + case 1013: + type_nam = "_oid8"; + break; + case 1014: + type_nam = "_lock"; + break; + case 1015: + type_nam = "_stub"; + break; + case 1016: + type_nam = "_ref"; + break; + case 1017: + type_nam = "_point"; + break; + case 1018: + type_nam = "_lseg"; + break; + case 1019: + type_nam = "_path"; + break; + case 1020: + type_nam = "_box"; + break; + case 1021: + type_nam = "_float4"; + break; + case 1022: + type_nam = "_float8"; + break; + case 1023: + type_nam = "_abstime"; + break; + case 1024: + type_nam = "_reltime"; + break; + case 1025: + type_nam = "_tinterval"; + break; + case 1026: + type_nam = "_filename"; + break; + case 1027: + type_nam = "_polygon"; + break; + case 1033: + type_nam = "aclitem"; + break; + case 1034: + type_nam = "_aclitem"; + break; + case 1042: + type_nam = "bpchar"; + break; + case 1043: + type_nam = "varchar"; + break; + case 1082: + type_nam = "date"; + break; + case 1083: + type_nam = "time"; + break; + case 1182: + type_nam = "_date"; + break; + case 1183: + type_nam = "_time"; + break; + case 1184: + type_nam = "datetime"; + break; + case 1185: + type_nam = "_datetime"; + break; + case 1186: + type_nam = "timespan"; + break; + case 1187: + type_nam = "_timespan"; + break; + case 1231: + type_nam = "_numeric"; + break; + case 1296: + type_nam = "timestamp"; + break; + case 1700: + type_nam = "numeric"; + break; + + default: + type_nam = "unknown"; + + } + av_store(av, i, newSVpv(type_nam, 0)); + } + } else if (kl==13 && strEQ(key, "pg_oid_status")) { + retsv = newSVpv((char *)PQoidStatus(imp_sth->result), 0); + } else if (kl==13 && strEQ(key, "pg_cmd_status")) { + retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0); + } else { + return Nullsv; + } + + return sv_2mortal(retsv); +} + + +/* end of dbdimp.c */