2 $Id: dbdimp.c,v 1.1 2004-04-29 09:21:28 ivan Exp $
4 Copyright (c) 1997,1998,1999,2000 Edmund Mergl
5 Copyright (c) 2002 Jeffrey W. Baker
6 Portions Copyright (c) 1994,1995,1996,1997 Tim Bunce
8 You may distribute under the terms of either the GNU General Public
9 License or the Artistic License, as specified in the Perl README file.
15 hard-coded OIDs: (here we need the postgresql types)
16 pg_sql_type() 1042 (bpchar), 1043 (varchar)
17 ddb_st_fetch() 1042 (bpchar), 16 (bool)
18 ddb_preparse() 1043 (varchar)
24 /* XXX DBI should provide a better version of this */
25 #define IS_DBI_HANDLE(h) (SvROK(h) && SvTYPE(SvRV(h)) == SVt_PVHV && SvRMAGICAL(SvRV(h)) && (SvMAGIC(SvRV(h)))->mg_type == 'P')
29 /* hard-coded array delimiter */
30 static char* array_delimiter = ",";
32 static void dbd_preparse (imp_sth_t *imp_sth, char *statement);
44 dbd_discon_all (drh, imp_drh)
50 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_discon_all\n"); }
52 /* The disconnect_all concept is flawed and needs more work */
53 if (!dirty && !SvTRUE(perl_get_sv("DBI::PERL_ENDING",0))) {
54 sv_setiv(DBIc_ERR(imp_drh), (IV)1);
55 sv_setpv(DBIc_ERRSTR(imp_drh),
56 (char*)"disconnect_all not implemented");
57 DBIh_EVENT2(drh, ERROR_event,
58 DBIc_ERR(imp_drh), DBIc_ERRSTR(imp_drh));
61 if (perl_destruct_level) {
62 perl_destruct_level = 0;
68 /* Database specific error handling. */
71 pg_error (h, error_num, error_msg)
77 char *err, *src, *dst;
78 int len = strlen(error_msg);
80 err = (char *)malloc(len + 1);
87 /* copy error message without trailing newlines */
88 while (*src != '\0' && *src != '\n') {
93 sv_setiv(DBIc_ERR(imp_xxh), (IV)error_num); /* set err early */
94 sv_setpv(DBIc_ERRSTR(imp_xxh), (char*)err);
95 DBIh_EVENT2(h, ERROR_event, DBIc_ERR(imp_xxh), DBIc_ERRSTR(imp_xxh));
96 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "%s error %d recorded: %s\n", err, error_num, SvPV(DBIc_ERRSTR(imp_xxh),na)); }
101 pgtype_bind_ok (dbtype)
104 /* basically we support types that can be returned as strings */
114 case 700: /* float4 */
115 case 701: /* float8 */
116 case 702: /* abstime */
117 case 703: /* reltime */
118 case 704: /* tinterval */
119 case 1042: /* bpchar */
120 case 1043: /* varchar */
121 case 1082: /* date */
122 case 1083: /* time */
123 case 1184: /* datetime */
124 case 1186: /* timespan */
125 case 1296: /* timestamp */
132 /* ================================================================== */
135 pg_db_login (dbh, imp_dbh, dbname, uid, pwd)
148 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "pg_db_login\n"); }
150 /* build connect string */
151 /* DBD-Pg syntax: 'dbname=dbname;host=host;port=port' */
152 /* pgsql syntax: 'dbname=dbname host=host port=port user=uid password=pwd' */
154 conn_str = (char *)malloc(strlen(dbname) + strlen(uid) + strlen(pwd) + 16 + 1);
172 strcat(conn_str, " user=");
173 strcat(conn_str, uid);
175 if (strlen(uid) && strlen(pwd)) {
176 strcat(conn_str, " password=");
177 strcat(conn_str, pwd);
180 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "pg_db_login: conn_str = >%s<\n", conn_str); }
182 /* make a connection to the database */
183 imp_dbh->conn = PQconnectdb(conn_str);
186 /* check to see that the backend connection was successfully made */
187 if (PQstatus(imp_dbh->conn) != CONNECTION_OK) {
188 pg_error(dbh, PQstatus(imp_dbh->conn), PQerrorMessage(imp_dbh->conn));
189 PQfinish(imp_dbh->conn);
193 imp_dbh->init_commit = 1; /* initialize AutoCommit */
194 imp_dbh->pg_auto_escape = 1; /* initialize pg_auto_escape */
195 imp_dbh->pg_bool_tf = 0; /* initialize pg_bool_tf */
197 DBIc_IMPSET_on(imp_dbh); /* imp_dbh set up now */
198 DBIc_ACTIVE_on(imp_dbh); /* call disconnect before freeing */
204 dbd_db_getfd (dbh, imp_dbh)
211 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_getfd\n"); }
213 return PQsocket(imp_dbh->conn);
217 dbd_db_pg_notifies (dbh, imp_dbh)
226 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_pg_notifies\n"); }
228 PQconsumeInput(imp_dbh->conn);
230 notify = PQnotifies(imp_dbh->conn);
232 if (!notify) return &sv_undef;
236 av_push(ret, newSVpv(notify->relname,0) );
237 av_push(ret, newSViv(notify->be_pid) );
239 /* Should free notify memory with PQfreemem() */
241 retsv = newRV(sv_2mortal((SV*)ret));
253 ExecStatusType status;
255 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_ping\n"); }
257 if (NULL != imp_dbh->conn) {
258 result = PQexec(imp_dbh->conn, " ");
259 status = result ? PQresultStatus(result) : -1;
262 if (PGRES_EMPTY_QUERY != status) {
274 dbd_db_commit (dbh, imp_dbh)
278 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_commit\n"); }
280 /* no commit if AutoCommit = on */
281 if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
285 if (NULL != imp_dbh->conn) {
286 PGresult* result = 0;
287 ExecStatusType commitstatus, beginstatus;
290 result = PQexec(imp_dbh->conn, "commit");
291 commitstatus = result ? PQresultStatus(result) : -1;
295 if (commitstatus != PGRES_COMMAND_OK) {
296 /* Only put the error message in DBH->errstr */
297 pg_error(dbh, commitstatus, PQerrorMessage(imp_dbh->conn));
300 /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */
301 result = PQexec(imp_dbh->conn, "begin");
302 beginstatus = result ? PQresultStatus(result) : -1;
304 if (beginstatus != PGRES_COMMAND_OK) {
305 /* Maybe add some loud barf here? Raising some very high error? */
306 pg_error(dbh, beginstatus, "begin failed\n");
310 /* if the initial COMMIT failed, return 0 now */
311 if (commitstatus != PGRES_COMMAND_OK) {
323 dbd_db_rollback (dbh, imp_dbh)
327 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_rollback\n"); }
329 /* no rollback if AutoCommit = on */
330 if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
334 if (NULL != imp_dbh->conn) {
335 PGresult* result = 0;
336 ExecStatusType status;
338 /* execute rollback */
339 result = PQexec(imp_dbh->conn, "rollback");
340 status = result ? PQresultStatus(result) : -1;
344 if (status != PGRES_COMMAND_OK) {
345 pg_error(dbh, status, "rollback failed\n");
349 /* start new transaction. AutoCommit must be FALSE, ref. 20 lines up */
350 result = PQexec(imp_dbh->conn, "begin");
351 status = result ? PQresultStatus(result) : -1;
353 if (status != PGRES_COMMAND_OK) {
354 pg_error(dbh, status, "begin failed\n");
366 dbd_db_disconnect (dbh, imp_dbh)
372 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect\n"); }
374 /* We assume that disconnect will always work */
375 /* since most errors imply already disconnected. */
376 DBIc_ACTIVE_off(imp_dbh);
378 if (NULL != imp_dbh->conn) {
379 /* rollback if AutoCommit = off */
380 if (DBIc_has(imp_dbh, DBIcf_AutoCommit) == FALSE) {
381 PGresult* result = 0;
382 ExecStatusType status;
383 result = PQexec(imp_dbh->conn, "rollback");
384 status = result ? PQresultStatus(result) : -1;
386 if (status != PGRES_COMMAND_OK) {
387 pg_error(dbh, status, "rollback failed\n");
390 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect: AutoCommit=off -> rollback\n"); }
393 PQfinish(imp_dbh->conn);
395 imp_dbh->conn = NULL;
398 /* We don't free imp_dbh since a reference still exists */
399 /* The DESTROY method is the only one to 'free' memory. */
400 /* Note that statement objects may still exists for this dbh! */
406 dbd_db_destroy (dbh, imp_dbh)
410 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_destroy\n"); }
412 if (DBIc_ACTIVE(imp_dbh)) {
413 dbd_db_disconnect(dbh, imp_dbh);
416 /* Nothing in imp_dbh to be freed */
417 DBIc_IMPSET_off(imp_dbh);
422 dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv)
429 char *key = SvPV(keysv,kl);
430 int newval = SvTRUE(valuesv);
432 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_STORE\n"); }
434 if (kl==10 && strEQ(key, "AutoCommit")) {
435 int oldval = DBIc_has(imp_dbh, DBIcf_AutoCommit);
436 DBIc_set(imp_dbh, DBIcf_AutoCommit, newval);
437 if (oldval == FALSE && newval != FALSE && imp_dbh->init_commit) {
438 /* do nothing, fall through */
439 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: initialize AutoCommit to on\n"); }
440 } else if (oldval == FALSE && newval != FALSE) {
441 if (NULL != imp_dbh->conn) {
442 /* commit any outstanding changes */
443 PGresult* result = 0;
444 ExecStatusType status;
445 result = PQexec(imp_dbh->conn, "commit");
446 status = result ? PQresultStatus(result) : -1;
448 if (status != PGRES_COMMAND_OK) {
449 pg_error(dbh, status, "commit failed\n");
453 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to on: commit\n"); }
454 } else if ((oldval != FALSE && newval == FALSE) || (oldval == FALSE && newval == FALSE && imp_dbh->init_commit)) {
455 if (NULL != imp_dbh->conn) {
456 /* start new transaction */
457 PGresult* result = 0;
458 ExecStatusType status;
459 result = PQexec(imp_dbh->conn, "begin");
460 status = result ? PQresultStatus(result) : -1;
462 if (status != PGRES_COMMAND_OK) {
463 pg_error(dbh, status, "begin failed\n");
467 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to off: begin\n"); }
469 /* only needed once */
470 imp_dbh->init_commit = 0;
472 } else if (kl==14 && strEQ(key, "pg_auto_escape")) {
473 imp_dbh->pg_auto_escape = newval;
474 } else if (kl==10 && strEQ(key, "pg_bool_tf")) {
475 imp_dbh->pg_bool_tf = newval;
477 } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
478 imp_dbh->pg_enable_utf8 = newval;
487 dbd_db_FETCH_attrib (dbh, imp_dbh, keysv)
493 char *key = SvPV(keysv,kl);
496 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_FETCH\n"); }
498 if (kl==10 && strEQ(key, "AutoCommit")) {
499 retsv = boolSV(DBIc_has(imp_dbh, DBIcf_AutoCommit));
500 } else if (kl==14 && strEQ(key, "pg_auto_escape")) {
501 retsv = newSViv((IV)imp_dbh->pg_auto_escape);
502 } else if (kl==10 && strEQ(key, "pg_bool_tf")) {
503 retsv = newSViv((IV)imp_dbh->pg_bool_tf);
505 } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
506 retsv = newSViv((IV)imp_dbh->pg_enable_utf8);
508 } else if (kl==11 && strEQ(key, "pg_INV_READ")) {
509 retsv = newSViv((IV)INV_READ);
510 } else if (kl==12 && strEQ(key, "pg_INV_WRITE")) {
511 retsv = newSViv((IV)INV_WRITE);
517 if (retsv == &sv_yes || retsv == &sv_no) {
518 return retsv; /* no need to mortalize yes or no */
520 return sv_2mortal(retsv);
524 /* driver specific functins */
528 pg_db_lo_open (dbh, lobjId, mode)
534 return lo_open(imp_dbh->conn, lobjId, mode);
539 pg_db_lo_close (dbh, fd)
544 return lo_close(imp_dbh->conn, fd);
549 pg_db_lo_read (dbh, fd, buf, len)
556 return lo_read(imp_dbh->conn, fd, buf, len);
561 pg_db_lo_write (dbh, fd, buf, len)
568 return lo_write(imp_dbh->conn, fd, buf, len);
573 pg_db_lo_lseek (dbh, fd, offset, whence)
580 return lo_lseek(imp_dbh->conn, fd, offset, whence);
585 pg_db_lo_creat (dbh, mode)
590 return lo_creat(imp_dbh->conn, mode);
595 pg_db_lo_tell (dbh, fd)
600 return lo_tell(imp_dbh->conn, fd);
605 pg_db_lo_unlink (dbh, lobjId)
610 return lo_unlink(imp_dbh->conn, lobjId);
615 pg_db_lo_import (dbh, filename)
620 return lo_import(imp_dbh->conn, filename);
625 pg_db_lo_export (dbh, lobjId, filename)
631 return lo_export(imp_dbh->conn, lobjId, filename);
636 pg_db_putline (dbh, buffer)
641 return PQputline(imp_dbh->conn, buffer);
646 pg_db_getline (dbh, buffer, length)
652 return PQgetline(imp_dbh->conn, buffer, length);
661 return PQendcopy(imp_dbh->conn);
665 /* ================================================================== */
669 dbd_st_prepare (sth, imp_sth, statement, attribs)
675 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_prepare: statement = >%s<\n", statement); }
677 /* scan statement for '?', ':1' and/or ':foo' style placeholders */
678 dbd_preparse(imp_sth, statement);
680 /* initialize new statement handle */
682 imp_sth->cur_tuple = 0;
684 DBIc_IMPSET_on(imp_sth);
690 dbd_preparse (imp_sth, statement)
694 bool in_literal = FALSE;
695 char in_comment = '\0';
696 char *src, *start, *dest;
700 char *style="", *laststyle=Nullch;
703 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_preparse: statement = >%s<\n", statement); }
705 /* allocate room for copy of statement with spare capacity */
706 /* for editing '?' or ':1' into ':p1'. */
708 /* Note: the calculated length used here for the safemalloc */
709 /* isn't related in any way to the actual worst case length */
710 /* of the translated statement, but allowing for 3 times */
711 /* the length of the original statement should be safe... */
712 imp_sth->statement = (char*)safemalloc(strlen(statement) * 3 + 1);
714 /* initialise phs ready to be cloned per placeholder */
715 memset(&phs_tpl, 0, sizeof(phs_tpl));
716 phs_tpl.ftype = 1043; /* VARCHAR */
719 dest = imp_sth->statement;
723 /* SQL-style and C++-style */
724 if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
728 else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
729 *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
737 /* check if literal ends but keep quotes in literal */
738 if (*src == in_literal) {
742 while (*(str-bs) == '\\')
751 /* Look for comments: SQL-style or C++-style or C-style */
752 if ((*src == '-' && *(src+1) == '-') ||
753 (*src == '/' && *(src+1) == '/') ||
754 (*src == '/' && *(src+1) == '*'))
756 in_comment = *(src+1);
757 /* We know *src & the next char are to be copied, so do */
758 /* it. In the case of C-style comments, it happens to */
759 /* help us avoid slash-asterisk-slash oddities. */
765 /* check if no placeholders */
766 if (*src != ':' && *src != '?') {
767 if (*src == '\'' || *src == '"') {
774 /* check for cast operator */
775 if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
780 /* only here for : or ? outside of a comment or literal and no cast */
782 start = dest; /* save name inc colon */
784 if (*start == '?') { /* X/Open standard */
785 sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */
786 dest = start+strlen(start);
789 } else if (isDIGIT(*src)) { /* ':1' */
791 *dest++ = 'p'; /* ':1'->':p1' */
793 croak("Placeholder :%d invalid, placeholders must be >= 1", idx);
795 while(isDIGIT(*src)) {
800 } else if (isALNUM(*src)) { /* ':foo' */
801 while(isALNUM(*src)) { /* includes '_' */
805 } else { /* perhaps ':=' PL/SQL construct */
808 *dest = '\0'; /* handy for debugging */
809 namelen = (dest-start);
810 if (laststyle && style != laststyle) {
811 croak("Can't mix placeholder styles (%s/%s)",style,laststyle);
814 if (imp_sth->all_params_hv == NULL) {
815 imp_sth->all_params_hv = newHV();
817 phs_tpl.sv = &sv_undef;
818 phs_sv = newSVpv((char*)&phs_tpl, sizeof(phs_tpl)+namelen+1);
819 hv_store(imp_sth->all_params_hv, start, namelen, phs_sv, 0);
820 strcpy( ((phs_t*)(void*)SvPVX(phs_sv))->name, start);
823 if (imp_sth->all_params_hv) {
824 DBIc_NUM_PARAMS(imp_sth) = (int)HvKEYS(imp_sth->all_params_hv);
825 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, " dbd_preparse scanned %d distinct placeholders\n", (int)DBIc_NUM_PARAMS(imp_sth)); }
830 /* if it LOOKS like a string, this function will determine whether the type needs to be surrounded in single quotes */
831 static int pg_sql_needquote (sql_type)
834 if (sql_type > 1000 || sql_type == 17 || sql_type == 25 ) {
843 pg_sql_type (imp_sth, name, sql_type)
850 return 1042; /* bpchar */
852 return 700; /* float4 */
854 return 700; /* float4 */
856 return 23; /* int4 */
858 return 21; /* int2 */
860 return 700; /* float4 */
862 return 701; /* float8 */
864 return 20; /* int8 */
866 return 1043; /* varchar */
868 return 17; /* bytea */
870 if (DBIc_WARN(imp_sth) && imp_sth && name) {
871 warn("SQL type %d for '%s' is not fully supported, bound as VARCHAR instead",
874 return pg_sql_type(imp_sth, name, SQL_VARCHAR);
879 sql_pg_type (imp_sth, name, sql_type)
884 if (dbis->debug >= 1) {
885 PerlIO_printf(DBILOGFP, "sql_pg_type name '%s' type '%d'\n", name, sql_type );
897 case 700: /* float4 */
899 case 701: /* float8 */
901 case 1042: /* bpchar */
903 case 1043: /* varchar */
905 case 1082: /* date */
907 case 1083: /* time */
909 case 1296: /* date */
910 return SQL_TIMESTAMP;
919 dbd_rebind_ph (sth, imp_sth, phs)
926 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rebind\n"); }
928 /* convert to a string ASAP */
929 if (!SvPOK(phs->sv) && SvOK(phs->sv)) {
930 sv_2pv(phs->sv, &na);
933 if (dbis->debug >= 2) {
934 char *val = neatsvpv(phs->sv,0);
935 PerlIO_printf(DBILOGFP, " bind %s <== %.1000s (", phs->name, val);
937 PerlIO_printf(DBILOGFP, "size %ld/%ld/%ld, ", (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen);
939 PerlIO_printf(DBILOGFP, "NULL, ");
941 PerlIO_printf(DBILOGFP, "ptype %d, otype %d%s)\n", (int)SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : "");
944 /* At the moment we always do sv_setsv() and rebind. */
945 /* Later we may optimise this so that more often we can */
946 /* just copy the value & length over and not rebind. */
948 if (phs->is_inout) { /* XXX */
949 if (SvREADONLY(phs->sv)) {
952 /* phs->sv _is_ the real live variable, it may 'mutate' later */
953 /* pre-upgrade high to reduce risk of SvPVX realloc/move */
954 (void)SvUPGRADE(phs->sv, SVt_PVNV);
955 /* ensure room for result, 28 is magic number (see sv_2pv) */
956 SvGROW(phs->sv, (phs->maxlen < 28) ? 28 : phs->maxlen+1);
959 /* phs->sv is copy of real variable, upgrade to at least string */
960 (void)SvUPGRADE(phs->sv, SVt_PV);
963 /* At this point phs->sv must be at least a PV with a valid buffer, */
964 /* even if it's undef (null) */
965 /* Here we set phs->progv, phs->indp, and value_len. */
967 phs->progv = SvPV(phs->sv, value_len);
970 else { /* it's null but point to buffer in case it's an out var */
971 phs->progv = SvPVX(phs->sv);
975 phs->sv_type = SvTYPE(phs->sv); /* part of mutation check */
976 phs->maxlen = SvLEN(phs->sv)-1; /* avail buffer space */
977 if (phs->maxlen < 0) { /* can happen with nulls */
981 phs->alen = value_len + phs->alen_incnull;
983 imp_sth->all_params_len += SvOK(phs->sv) ? phs->alen : 4; /* NULL */
985 if (dbis->debug >= 3) {
986 PerlIO_printf(DBILOGFP, " bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n",
988 (int)(phs->alen>SvIV(DBIS->neatsvpvlen) ? SvIV(DBIS->neatsvpvlen) : phs->alen),
989 (phs->progv) ? phs->progv : "",
990 (long)phs->alen, (long)phs->maxlen, phs->ftype, phs->indp);
997 void dereference(value)
1006 if (SvTYPE(SvRV(*value)) != SVt_PVAV)
1007 croak("Not an array reference (%s)", neatsvpv(*value,0));
1009 buf = (AV *) SvRV(*value);
1010 sv_setpv(*value, "{");
1011 while ( SvOK(val = av_shift(buf)) ) {
1012 is_ref = SvROK(val);
1016 sv_catpv(*value, "\"");
1018 src = SvPV(val, len);
1020 if (!is_ref && *src == '\"')
1021 sv_catpv(*value, "\\");
1022 sv_catpvn(*value, src++, 1);
1026 sv_catpv(*value, "\"");
1027 if (av_len(buf) > -1)
1028 sv_catpv(*value, array_delimiter);
1030 sv_catpv(*value, "}");
1035 dbd_bind_ph (sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen)
1051 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_bind_ph\n"); }
1053 /* check if placeholder was passed as a number */
1055 if (SvGMAGICAL(ph_namesv)) { /* eg if from tainted expression */
1058 if (!SvNIOKp(ph_namesv)) {
1059 name = SvPV(ph_namesv, name_len);
1061 if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) {
1062 sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv));
1064 name_len = strlen(name);
1066 assert(name != Nullch);
1068 if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic */
1069 croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0));
1071 if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) {
1072 /* dbi handle allowed for cursor variables */
1073 dereference(&newvalue);
1075 if (SvTYPE(newvalue) == SVt_PVLV && is_inout) { /* may allow later */
1076 croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)");
1079 if (dbis->debug >= 2) {
1080 PerlIO_printf(DBILOGFP, " bind %s <== %s (type %ld", name, neatsvpv(newvalue,0), (long)sql_type);
1082 PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld", (long)newvalue, (long)maxlen);
1085 PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0));
1087 PerlIO_printf(DBILOGFP, ")\n");
1090 phs_svp = hv_fetch(imp_sth->all_params_hv, name, name_len, 0);
1091 if (phs_svp == NULL) {
1092 croak("Can't bind unknown placeholder '%s' (%s)", name, neatsvpv(ph_namesv,0));
1094 phs = (phs_t*)(void*)SvPVX(*phs_svp); /* placeholder struct */
1096 if (phs->sv == &sv_undef) { /* first bind for this placeholder */
1097 phs->ftype = 1043; /* our default type VARCHAR */
1098 phs->is_inout = is_inout;
1100 /* phs->sv assigned in the code below */
1101 ++imp_sth->has_inout_params;
1102 /* build array of phs's so we can deal with out vars fast */
1103 if (!imp_sth->out_params_av) {
1104 imp_sth->out_params_av = newAV();
1106 av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp));
1109 if (attribs) { /* only look for pg_type on first bind of var */
1111 /* Setup / Clear attributes as defined by attribs. */
1112 /* XXX If attribs is EMPTY then reset attribs to default? */
1113 if ( (svp = hv_fetch((HV*)SvRV(attribs), "pg_type", 7, 0)) != NULL) {
1114 int pg_type = SvIV(*svp);
1115 if (!pgtype_bind_ok(pg_type)) {
1116 croak("Can't bind %s, pg_type %d not supported by DBD::Pg", phs->name, pg_type);
1119 croak("Can't specify both TYPE (%d) and pg_type (%d) for %s", sql_type, pg_type, phs->name);
1121 phs->ftype = pg_type;
1125 /* SQL_BINARY (-2) is deprecated. */
1126 if (sql_type == -2 && DBIc_WARN(imp_sth)) {
1127 warn("Use of SQL type SQL_BINARY (%d) is deprecated. Use { pg_type => DBD::Pg::PG_BYTEA } instead.", sql_type);
1129 phs->ftype = pg_sql_type(imp_sth, phs->name, sql_type);
1131 } /* was first bind for this placeholder */
1133 /* check later rebinds for any changes */
1134 else if (is_inout || phs->is_inout) {
1135 croak("Can't rebind or change param %s in/out mode after first bind (%d => %d)", phs->name, phs->is_inout , is_inout);
1137 else if (sql_type && phs->ftype != pg_sql_type(imp_sth, phs->name, sql_type)) {
1138 croak("Can't change TYPE of param %s to %d after initial bind", phs->name, sql_type);
1141 phs->maxlen = maxlen; /* 0 if not inout */
1143 if (!is_inout) { /* normal bind to take a (new) copy of current value */
1144 if (phs->sv == &sv_undef) { /* (first time bind) */
1147 sv_setsv(phs->sv, newvalue);
1148 } else if (newvalue != phs->sv) {
1150 SvREFCNT_dec(phs->sv);
1152 phs->sv = SvREFCNT_inc(newvalue); /* point to live var */
1155 return dbd_rebind_ph(sth, imp_sth, phs);
1160 dbd_st_execute (sth, imp_sth) /* <= -2:error, >=0:ok row count, (-1=unknown count) */
1167 ExecStatusType status = -1;
1175 bool in_literal = FALSE;
1176 char in_comment = '\0';
1184 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_execute\n"); }
1187 here we get the statement from the statement handle where
1188 it has been stored when creating a blank sth during prepare
1189 svp = hv_fetch((HV *)SvRV(sth), "Statement", 9, FALSE);
1190 statement = SvPV(*svp, na);
1193 if (NULL == imp_dbh->conn) {
1194 pg_error(sth, -1, "execute on disconnected handle");
1198 statement = imp_sth->statement;
1200 /* are we prepared ? */
1201 pg_error(sth, -1, "statement not prepared\n");
1205 /* do we have input parameters ? */
1206 if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
1208 we have to allocate some additional memory for possible escaping
1209 quotes and backslashes:
1210 max_len = length of statement
1211 + total length of all params allowing for worst case all
1212 characters binary-escaped (\\xxx)
1214 Note: parameters look like :p1 at this point, so there's no
1215 need to explicitly allow for surrounding quotes because '' is
1218 int max_len = strlen(imp_sth->statement) + imp_sth->all_params_len * 5 + 1;
1219 statement = (char*)safemalloc( max_len );
1221 src = imp_sth->statement;
1222 /* scan statement for ':p1' style placeholders */
1226 /* SQL-style and C++-style */
1227 if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
1231 else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
1232 *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
1240 /* check if literal ends but keep quotes in literal */
1241 if (*src == in_literal) {
1245 while (*(str-bs) == '\\')
1254 /* Look for comments: SQL-style or C++-style or C-style */
1255 if ((*src == '-' && *(src+1) == '-') ||
1256 (*src == '/' && *(src+1) == '/') ||
1257 (*src == '/' && *(src+1) == '*'))
1259 in_comment = *(src+1);
1260 /* We know *src & the next char are to be copied, so do */
1261 /* it. In the case of C-style comments, it happens to */
1262 /* help us avoid slash-asterisk-slash oddities. */
1268 /* check if no placeholders */
1269 if (*src != ':' && *src != '?') {
1270 if (*src == '\'' || *src == '"') {
1277 /* check for cast operator */
1278 if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
1285 namebuf[i++] = *src++; /* ':' */
1286 namebuf[i++] = *src++; /* 'p' */
1288 while (isDIGIT(*src) && i < (sizeof(namebuf)-1) ) {
1289 namebuf[i++] = *src++;
1291 if ( i == (sizeof(namebuf) - 1)) {
1292 pg_error(sth, -1, "namebuf buffer overrun\n");
1296 svp = hv_fetch(imp_sth->all_params_hv, namebuf, i, 0);
1298 pg_error(sth, -1, "parameter unknown\n");
1302 phs = (phs_t*)(void*)SvPVX(*svp);
1303 /* replace undef with NULL */
1304 if(!SvOK(phs->sv)) {
1308 val = SvPV(phs->sv, len);
1310 /* quote string attribute */
1311 if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */
1315 if (imp_dbh->pg_auto_escape) {
1316 /* if the parameter was bound as PG_BYTEA, escape nonprintables */
1317 if (phs->ftype == 17 && !isPRINT(*val)) { /* escape null character */
1318 dest+=snprintf(dest, (statement + max_len) - dest, "\\\\%03o", *((unsigned char *)val));
1319 if (dest > statement + max_len) {
1320 pg_error(sth, -1, "statement buffer overrun\n");
1324 continue; /* do not copy the null */
1330 /* escape backslash */
1332 if (phs->ftype == 17) { /* four backslashes. really. */
1341 /* copy attribute to statement */
1344 /* quote string attribute */
1345 if(!SvNIOK(phs->sv) && SvOK(phs->sv) && pg_sql_needquote(phs->ftype)) { /* avoid quoting NULL, tpf: bind_param as numeric */
1352 if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_st_execute: statement = >%s<\n", statement); }
1354 /* clear old result (if any) */
1355 if (imp_sth->result) {
1356 PQclear(imp_sth->result);
1359 /* execute statement */
1360 imp_sth->result = PQexec(imp_dbh->conn, statement);
1362 /* free statement string in case of input parameters */
1363 if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
1364 Safefree(statement);
1368 status = imp_sth->result ? PQresultStatus(imp_sth->result) : -1;
1369 cmdStatus = imp_sth->result ? (char *)PQcmdStatus(imp_sth->result) : "";
1370 cmdTuples = imp_sth->result ? (char *)PQcmdTuples(imp_sth->result) : "";
1372 if (PGRES_TUPLES_OK == status) {
1373 /* select statement */
1374 num_fields = PQnfields(imp_sth->result);
1375 imp_sth->cur_tuple = 0;
1376 DBIc_NUM_FIELDS(imp_sth) = num_fields;
1377 DBIc_ACTIVE_on(imp_sth);
1378 ret = PQntuples(imp_sth->result);
1379 } else if (PGRES_COMMAND_OK == status) {
1380 /* non-select statement */
1381 if (! strncmp(cmdStatus, "DELETE", 6) || ! strncmp(cmdStatus, "INSERT", 6) || ! strncmp(cmdStatus, "UPDATE", 6)) {
1382 ret = atoi(cmdTuples);
1386 } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) {
1387 /* Copy Out/In data transfer in progress */
1390 pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1394 /* store the number of affected rows */
1395 imp_sth->rows = ret;
1402 is_high_bit_set(val)
1406 if (*val & 0x80) return 1;
1411 dbd_st_fetch (sth, imp_sth)
1420 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_fetch\n"); }
1422 /* Check that execute() was executed sucessfully */
1423 if ( !DBIc_ACTIVE(imp_sth) ) {
1424 pg_error(sth, 1, "no statement executing\n");
1429 if ( imp_sth->cur_tuple == PQntuples(imp_sth->result) ) {
1430 imp_sth->cur_tuple = 0;
1431 DBIc_ACTIVE_off(imp_sth);
1432 return Nullav; /* we reached the last tuple */
1435 av = DBIS->get_fbav(imp_sth);
1436 num_fields = AvFILL(av)+1;
1438 for(i = 0; i < num_fields; ++i) {
1440 SV *sv = AvARRAY(av)[i];
1441 if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)) {
1442 sv_setsv(sv, &sv_undef);
1444 char *val = (char*)PQgetvalue(imp_sth->result, imp_sth->cur_tuple, i);
1445 int val_len = strlen(val);
1446 int type = PQftype(imp_sth->result, i); /* hopefully these hard coded values will not change */
1447 if (16 == type && ! imp_dbh->pg_bool_tf) {
1448 *val = (*val == 'f') ? '0' : '1'; /* bool: translate postgres into perl */
1450 if (17 == type) { /* decode \001 -> chr(1), etc, in-place */
1451 char *p = val; /* points to next available pos */
1452 char *s = val; /* points to current scanning pos */
1456 if (*(s+1) == '\\') { /* double backslash */
1461 else if ( isdigit(c1=(*(s+1))) &&
1462 isdigit(c2=(*(s+2))) &&
1463 isdigit(c3=(*(s+3))) ) {
1464 *p++ = (c1 - '0') * 64 + (c2 - '0') * 8 + (c3 - '0');
1471 val_len = (p - val);
1473 else if (1042 == type && DBIc_has(imp_sth,DBIcf_ChopBlanks)) {
1475 while((val_len > 0) && (str[val_len-1] == ' ')) {
1478 val[val_len] = '\0';
1480 sv_setpvn(sv, val, val_len);
1482 if (imp_dbh->pg_enable_utf8) {
1484 /* XXX Is this all the character data types? */
1485 if (18 == type || 25 == type || 1042 ==type || 1043 == type) {
1486 if (is_high_bit_set(val) && is_utf8_string(val, val_len))
1494 imp_sth->cur_tuple += 1;
1501 dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset)
1511 int ret, lobj_fd, nbytes, nread;
1513 ExecStatusType status;
1517 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_blob_read\n"); }
1520 pg_error(sth, -1, "dbd_st_blob_read: lobjId <= 0");
1524 pg_error(sth, -1, "dbd_st_blob_read: offset < 0");
1528 pg_error(sth, -1, "dbd_st_blob_read: len < 0");
1531 if (! SvROK(destrv)) {
1532 pg_error(sth, -1, "dbd_st_blob_read: destrv not a reference");
1535 if (destoffset < 0) {
1536 pg_error(sth, -1, "dbd_st_blob_read: destoffset < 0");
1540 /* dereference destination and ensure it's writable string */
1541 bufsv = SvRV(destrv);
1543 sv_setpvn(bufsv, "", 0);
1547 result = PQexec(imp_dbh->conn, "begin");
1548 status = result ? PQresultStatus(result) : -1;
1550 if (status != PGRES_COMMAND_OK) {
1551 pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1556 /* open large object */
1557 lobj_fd = lo_open(imp_dbh->conn, lobjId, INV_READ);
1559 pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1563 /* seek on large object */
1565 ret = lo_lseek(imp_dbh->conn, lobj_fd, offset, SEEK_SET);
1567 pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1572 /* read from large object */
1574 SvGROW(bufsv, destoffset + nread + BUFSIZ + 1);
1575 tmp = (SvPVX(bufsv)) + destoffset + nread;
1576 while ((nbytes = lo_read(imp_dbh->conn, lobj_fd, tmp, BUFSIZ)) > 0) {
1578 /* break if user wants only a specified chunk */
1579 if (len > 0 && nread > len) {
1583 SvGROW(bufsv, destoffset + nread + BUFSIZ + 1);
1584 tmp = (SvPVX(bufsv)) + destoffset + nread;
1587 /* terminate string */
1588 SvCUR_set(bufsv, destoffset + nread);
1589 *SvEND(bufsv) = '\0';
1591 /* close large object */
1592 ret = lo_close(imp_dbh->conn, lobj_fd);
1594 pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1599 result = PQexec(imp_dbh->conn, "end");
1600 status = result ? PQresultStatus(result) : -1;
1602 if (status != PGRES_COMMAND_OK) {
1603 pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1613 dbd_st_rows (sth, imp_sth)
1617 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rows\n"); }
1619 return imp_sth->rows;
1624 dbd_st_finish (sth, imp_sth)
1630 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_finish\n"); }
1632 if (DBIc_ACTIVE(imp_sth) && imp_sth->result) {
1633 PQclear(imp_sth->result);
1634 imp_sth->result = 0;
1638 DBIc_ACTIVE_off(imp_sth);
1644 dbd_st_destroy (sth, imp_sth)
1648 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_destroy\n"); }
1650 /* Free off contents of imp_sth */
1652 Safefree(imp_sth->statement);
1653 if (imp_sth->result) {
1654 PQclear(imp_sth->result);
1655 imp_sth->result = 0;
1658 if (imp_sth->out_params_av)
1659 sv_free((SV*)imp_sth->out_params_av);
1661 if (imp_sth->all_params_hv) {
1662 HV *hv = imp_sth->all_params_hv;
1667 while( (sv = hv_iternextsv(hv, &key, &retlen)) != NULL ) {
1668 if (sv != &sv_undef) {
1669 phs_t *phs_tpl = (phs_t*)(void*)SvPVX(sv);
1670 sv_free(phs_tpl->sv);
1673 sv_free((SV*)imp_sth->all_params_hv);
1676 DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
1681 dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv)
1687 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_STORE\n"); }
1694 dbd_st_FETCH_attrib (sth, imp_sth, keysv)
1700 char *key = SvPV(keysv,kl);
1704 if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_FETCH\n"); }
1706 if (! imp_sth->result) {
1710 i = DBIc_NUM_FIELDS(imp_sth);
1712 if (kl == 4 && strEQ(key, "NAME")) {
1714 retsv = newRV(sv_2mortal((SV*)av));
1716 av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0));
1718 } else if ( kl== 4 && strEQ(key, "TYPE")) {
1719 /* Need to convert the Pg type to ANSI/SQL type. */
1721 retsv = newRV(sv_2mortal((SV*)av));
1723 av_store(av, i, newSViv(sql_pg_type( imp_sth,
1724 PQfname(imp_sth->result, i),
1725 PQftype(imp_sth->result, i))));
1727 } else if (kl==9 && strEQ(key, "PRECISION")) {
1729 retsv = newRV(sv_2mortal((SV*)av));
1731 sz = PQfsize(imp_sth->result, i);
1732 av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef);
1734 } else if (kl==5 && strEQ(key, "SCALE")) {
1736 retsv = newRV(sv_2mortal((SV*)av));
1738 av_store(av, i, &sv_undef);
1740 } else if (kl==8 && strEQ(key, "NULLABLE")) {
1742 retsv = newRV(sv_2mortal((SV*)av));
1744 av_store(av, i, newSViv(2));
1746 } else if (kl==10 && strEQ(key, "CursorName")) {
1748 } else if (kl==11 && strEQ(key, "RowsInCache")) {
1750 } else if (kl==7 && strEQ(key, "pg_size")) {
1752 retsv = newRV(sv_2mortal((SV*)av));
1754 av_store(av, i, newSViv(PQfsize(imp_sth->result, i)));
1756 } else if (kl==7 && strEQ(key, "pg_type")) {
1759 retsv = newRV(sv_2mortal((SV*)av));
1761 switch (PQftype(imp_sth->result, i)) {
1787 type_nam = "regproc";
1826 type_nam = "polygon";
1829 type_nam = "filename";
1838 type_nam = "float4";
1841 type_nam = "float8";
1844 type_nam = "abstime";
1847 type_nam = "reltime";
1850 type_nam = "tinterval";
1853 type_nam = "unknown";
1856 type_nam = "circle";
1859 type_nam = "_circle";
1865 type_nam = "_money";
1868 type_nam = "oidint2";
1871 type_nam = "oidint4";
1874 type_nam = "oidname";
1880 type_nam = "_bytea";
1892 type_nam = "_int28";
1898 type_nam = "_regproc";
1928 type_nam = "_point";
1940 type_nam = "_float4";
1943 type_nam = "_float8";
1946 type_nam = "_abstime";
1949 type_nam = "_reltime";
1952 type_nam = "_tinterval";
1955 type_nam = "_filename";
1958 type_nam = "_polygon";
1961 type_nam = "aclitem";
1964 type_nam = "_aclitem";
1967 type_nam = "bpchar";
1970 type_nam = "varchar";
1985 type_nam = "datetime";
1988 type_nam = "_datetime";
1991 type_nam = "timespan";
1994 type_nam = "_timespan";
1997 type_nam = "_numeric";
2000 type_nam = "timestamp";
2003 type_nam = "numeric";
2007 type_nam = "unknown";
2010 av_store(av, i, newSVpv(type_nam, 0));
2012 } else if (kl==13 && strEQ(key, "pg_oid_status")) {
2013 retsv = newSVpv((char *)PQoidStatus(imp_sth->result), 0);
2014 } else if (kl==13 && strEQ(key, "pg_cmd_status")) {
2015 retsv = newSVpv((char *)PQcmdStatus(imp_sth->result), 0);
2020 return sv_2mortal(retsv);
2024 /* end of dbdimp.c */