install/5.005/DBD-Pg-1.22-fixvercmp/dbdimp.c

   1 /*
   2    $Id: dbdimp.c,v 1.1 2004-04-29 09:21:28 ivan Exp $
   3
   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
   7
   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.
  10
  11 */
  12
  13
  14 /*
  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)
  19                     pgtype_bind_ok()
  20 */
  21
  22 #include "Pg.h"
  23
  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')
  26
  27 DBISTATE_DECLARE;
  28
  29 /* hard-coded array delimiter */
  30 static char* array_delimiter = ",";
  31
  32 static void dbd_preparse  (imp_sth_t *imp_sth, char *statement);
  33
  34
  35 void
  36 dbd_init (dbistate)
  37     dbistate_t *dbistate;
  38 {
  39     DBIS = dbistate;
  40 }
  41
  42
  43 int
  44 dbd_discon_all (drh, imp_drh)
  45     SV *drh;
  46     imp_drh_t *imp_drh;
  47 {
  48     dTHR;
  49
  50     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_discon_all\n"); }
  51
  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));
  59         return FALSE;
  60     }
  61     if (perl_destruct_level) {
  62         perl_destruct_level = 0;
  63     }
  64     return FALSE;
  65 }
  66
  67
  68 /* Database specific error handling. */
  69
  70 void
  71 pg_error (h, error_num, error_msg)
  72     SV *h;
  73     int error_num;
  74     char *error_msg;
  75 {
  76     D_imp_xxh(h);
  77     char *err, *src, *dst;
  78     int  len  = strlen(error_msg);
  79
  80     err = (char *)malloc(len + 1);
  81     if (!err) {
  82       return;
  83     }
  84     src = error_msg;
  85     dst = err;
  86
  87     /* copy error message without trailing newlines */
  88     while (*src != '\0' && *src != '\n') {
  89         *dst++ = *src++;
  90     }
  91     *dst = '\0';
  92
  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)); }
  97     free(err);
  98 }
  99
 100 static int
 101 pgtype_bind_ok (dbtype)
 102     int dbtype;
 103 {
 104     /* basically we support types that can be returned as strings */
 105     switch(dbtype) {
 106     case   16:  /* bool         */
 107     case   17:  /* bytea        */
 108     case   18:  /* char         */
 109     case   20:  /* int8         */
 110     case   21:  /* int2         */
 111     case   23:  /* int4         */
 112     case   25:  /* text         */
 113     case   26:  /* oid          */
 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    */
 126         return 1;
 127     }
 128     return 0;
 129 }
 130
 131
 132 /* ================================================================== */
 133
 134 int
 135 pg_db_login (dbh, imp_dbh, dbname, uid, pwd)
 136     SV *dbh;
 137     imp_dbh_t *imp_dbh;
 138     char *dbname;
 139     char *uid;
 140     char *pwd;
 141 {
 142     dTHR;
 143
 144     char *conn_str;
 145     char *src;
 146     char *dest;
 147
 148     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "pg_db_login\n"); }
 149
 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' */
 153
 154     conn_str = (char *)malloc(strlen(dbname) + strlen(uid) + strlen(pwd) + 16 + 1);
 155     if (! conn_str) {
 156         return 0;
 157     }
 158
 159     src  = dbname;
 160     dest = conn_str;
 161     while (*src) {
 162         if (*src != ';') {
 163             *dest++ = *src++;
 164             continue;
 165         }
 166         *dest++ = ' ';
 167         src++;
 168     }
 169     *dest = '\0';
 170
 171     if (strlen(uid)) {
 172         strcat(conn_str, " user=");
 173         strcat(conn_str, uid);
 174     }
 175     if (strlen(uid) && strlen(pwd)) {
 176         strcat(conn_str, " password=");
 177         strcat(conn_str, pwd);
 178     }
 179
 180     if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "pg_db_login: conn_str = >%s<\n", conn_str); }
 181
 182     /* make a connection to the database */
 183     imp_dbh->conn = PQconnectdb(conn_str);
 184     free(conn_str);
 185
 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);
 190         return 0;
 191     }
 192
 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 */
 196
 197     DBIc_IMPSET_on(imp_dbh);                    /* imp_dbh set up now */
 198     DBIc_ACTIVE_on(imp_dbh);                    /* call disconnect before freeing */
 199     return 1;
 200 }
 201
 202
 203 int
 204 dbd_db_getfd (dbh, imp_dbh)
 205     SV *dbh;
 206     imp_dbh_t *imp_dbh;
 207 {
 208     char id;
 209     SV* retsv;
 210
 211     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_getfd\n"); }
 212
 213     return PQsocket(imp_dbh->conn);
 214 }
 215
 216 SV *
 217 dbd_db_pg_notifies (dbh, imp_dbh)
 218     SV *dbh;
 219     imp_dbh_t *imp_dbh;
 220 {
 221     char id;
 222     PGnotify* notify;
 223     AV* ret;
 224     SV* retsv;
 225
 226     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_pg_notifies\n"); }
 227
 228     PQconsumeInput(imp_dbh->conn);
 229
 230     notify = PQnotifies(imp_dbh->conn);
 231
 232     if (!notify) return &sv_undef;
 233
 234     ret=newAV();
 235
 236     av_push(ret, newSVpv(notify->relname,0) );
 237     av_push(ret, newSViv(notify->be_pid) );
 238
 239     /* Should free notify memory with PQfreemem() */
 240
 241     retsv = newRV(sv_2mortal((SV*)ret));
 242
 243     return retsv;
 244 }
 245
 246 int
 247 dbd_db_ping (dbh)
 248     SV *dbh;
 249 {
 250     char id;
 251     D_imp_dbh(dbh);
 252     PGresult* result;
 253     ExecStatusType status;
 254
 255     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_ping\n"); }
 256
 257     if (NULL != imp_dbh->conn) {
 258         result = PQexec(imp_dbh->conn, " ");
 259         status = result ? PQresultStatus(result) : -1;
 260         PQclear(result);
 261
 262         if (PGRES_EMPTY_QUERY != status) {
 263             return 0;
 264         }
 265
 266         return 1;
 267     }
 268
 269     return 0;
 270 }
 271
 272
 273 int
 274 dbd_db_commit (dbh, imp_dbh)
 275     SV *dbh;
 276     imp_dbh_t *imp_dbh;
 277 {
 278     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_commit\n"); }
 279
 280     /* no commit if AutoCommit = on */
 281     if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
 282         return 0;
 283     }
 284
 285     if (NULL != imp_dbh->conn) {
 286         PGresult* result = 0;
 287         ExecStatusType commitstatus, beginstatus;
 288
 289         /* execute commit */
 290         result = PQexec(imp_dbh->conn, "commit");
 291         commitstatus = result ? PQresultStatus(result) : -1;
 292         PQclear(result);
 293
 294         /* check result */
 295         if (commitstatus != PGRES_COMMAND_OK) {
 296             /* Only put the error message in DBH->errstr */
 297             pg_error(dbh, commitstatus, PQerrorMessage(imp_dbh->conn));
 298         }
 299
 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;
 303         PQclear(result);
 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");
 307             return 0;
 308         }
 309
 310         /* if the initial COMMIT failed, return 0 now */
 311         if (commitstatus != PGRES_COMMAND_OK) {
 312             return 0;
 313         }
 314
 315         return 1;
 316     }
 317
 318     return 0;
 319 }
 320
 321
 322 int
 323 dbd_db_rollback (dbh, imp_dbh)
 324     SV *dbh;
 325     imp_dbh_t *imp_dbh;
 326 {
 327     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_rollback\n"); }
 328
 329     /* no rollback if AutoCommit = on */
 330     if (DBIc_has(imp_dbh, DBIcf_AutoCommit) != FALSE) {
 331         return 0;
 332     }
 333
 334     if (NULL != imp_dbh->conn) {
 335         PGresult* result = 0;
 336         ExecStatusType status;
 337
 338         /* execute rollback */
 339         result = PQexec(imp_dbh->conn, "rollback");
 340         status = result ? PQresultStatus(result) : -1;
 341         PQclear(result);
 342
 343         /* check result */
 344         if (status != PGRES_COMMAND_OK) {
 345             pg_error(dbh, status, "rollback failed\n");
 346             return 0;
 347         }
 348
 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;
 352         PQclear(result);
 353         if (status != PGRES_COMMAND_OK) {
 354             pg_error(dbh, status, "begin failed\n");
 355             return 0;
 356         }
 357
 358         return 1;
 359     }
 360
 361     return 0;
 362 }
 363
 364
 365 int
 366 dbd_db_disconnect (dbh, imp_dbh)
 367     SV *dbh;
 368     imp_dbh_t *imp_dbh;
 369 {
 370     dTHR;
 371
 372     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect\n"); }
 373
 374     /* We assume that disconnect will always work       */
 375     /* since most errors imply already disconnected.    */
 376     DBIc_ACTIVE_off(imp_dbh);
 377
 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;
 385             PQclear(result);
 386             if (status != PGRES_COMMAND_OK) {
 387                 pg_error(dbh, status, "rollback failed\n");
 388                 return 0;
 389             }
 390             if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_disconnect: AutoCommit=off -> rollback\n"); }
 391         }
 392
 393         PQfinish(imp_dbh->conn);
 394
 395         imp_dbh->conn = NULL;
 396     }
 397
 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!       */
 401     return 1;
 402 }
 403
 404
 405 void
 406 dbd_db_destroy (dbh, imp_dbh)
 407     SV *dbh;
 408     imp_dbh_t *imp_dbh;
 409 {
 410     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_destroy\n"); }
 411
 412     if (DBIc_ACTIVE(imp_dbh)) {
 413         dbd_db_disconnect(dbh, imp_dbh);
 414     }
 415
 416     /* Nothing in imp_dbh to be freed   */
 417     DBIc_IMPSET_off(imp_dbh);
 418 }
 419
 420
 421 int
 422 dbd_db_STORE_attrib (dbh, imp_dbh, keysv, valuesv)
 423     SV *dbh;
 424     imp_dbh_t *imp_dbh;
 425     SV *keysv;
 426     SV *valuesv;
 427 {
 428     STRLEN kl;
 429     char *key = SvPV(keysv,kl);
 430     int newval = SvTRUE(valuesv);
 431
 432     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_STORE\n"); }
 433
 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;
 447                 PQclear(result);
 448                 if (status != PGRES_COMMAND_OK) {
 449                     pg_error(dbh, status, "commit failed\n");
 450                     return 0;
 451                 }
 452             }
 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;
 461                 PQclear(result);
 462                 if (status != PGRES_COMMAND_OK) {
 463                     pg_error(dbh, status, "begin failed\n");
 464                     return 0;
 465                 }
 466             }
 467             if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_db_STORE: switch AutoCommit to off: begin\n"); }
 468         }
 469         /* only needed once */
 470         imp_dbh->init_commit = 0;
 471         return 1;
 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;
 476 #ifdef SvUTF8_off
 477     } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
 478         imp_dbh->pg_enable_utf8 = newval;
 479 #endif
 480     } else {
 481         return 0;
 482     }
 483 }
 484
 485
 486 SV *
 487 dbd_db_FETCH_attrib (dbh, imp_dbh, keysv)
 488     SV *dbh;
 489     imp_dbh_t *imp_dbh;
 490     SV *keysv;
 491 {
 492     STRLEN kl;
 493     char *key = SvPV(keysv,kl);
 494     SV *retsv = Nullsv;
 495
 496     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_db_FETCH\n"); }
 497
 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);
 504 #ifdef SvUTF8_off
 505     } else if (kl==14 && strEQ(key, "pg_enable_utf8")) {
 506         retsv = newSViv((IV)imp_dbh->pg_enable_utf8);
 507 #endif
 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);
 512     }
 513
 514     if (!retsv) {
 515         return Nullsv;
 516     }
 517     if (retsv == &sv_yes || retsv == &sv_no) {
 518         return retsv; /* no need to mortalize yes or no */
 519     }
 520     return sv_2mortal(retsv);
 521 }
 522
 523
 524 /* driver specific functins */
 525
 526
 527 int
 528 pg_db_lo_open (dbh, lobjId, mode)
 529     SV *dbh;
 530     unsigned int lobjId;
 531     int mode;
 532 {
 533     D_imp_dbh(dbh);
 534     return lo_open(imp_dbh->conn, lobjId, mode);
 535 }
 536
 537
 538 int
 539 pg_db_lo_close (dbh, fd)
 540     SV *dbh;
 541     int fd;
 542 {
 543     D_imp_dbh(dbh);
 544     return lo_close(imp_dbh->conn, fd);
 545 }
 546
 547
 548 int
 549 pg_db_lo_read (dbh, fd, buf, len)
 550     SV *dbh;
 551     int fd;
 552     char *buf;
 553     int len;
 554 {
 555     D_imp_dbh(dbh);
 556     return lo_read(imp_dbh->conn, fd, buf, len);
 557 }
 558
 559
 560 int
 561 pg_db_lo_write (dbh, fd, buf, len)
 562     SV *dbh;
 563     int fd;
 564     char *buf;
 565     int len;
 566 {
 567     D_imp_dbh(dbh);
 568     return lo_write(imp_dbh->conn, fd, buf, len);
 569 }
 570
 571
 572 int
 573 pg_db_lo_lseek (dbh, fd, offset, whence)
 574     SV *dbh;
 575     int fd;
 576     int offset;
 577     int whence;
 578 {
 579     D_imp_dbh(dbh);
 580     return lo_lseek(imp_dbh->conn, fd, offset, whence);
 581 }
 582
 583
 584 unsigned int
 585 pg_db_lo_creat (dbh, mode)
 586     SV *dbh;
 587     int mode;
 588 {
 589     D_imp_dbh(dbh);
 590     return lo_creat(imp_dbh->conn, mode);
 591 }
 592
 593
 594 int
 595 pg_db_lo_tell (dbh, fd)
 596     SV *dbh;
 597     int fd;
 598 {
 599     D_imp_dbh(dbh);
 600     return lo_tell(imp_dbh->conn, fd);
 601 }
 602
 603
 604 int
 605 pg_db_lo_unlink (dbh, lobjId)
 606     SV *dbh;
 607     unsigned int lobjId;
 608 {
 609     D_imp_dbh(dbh);
 610     return lo_unlink(imp_dbh->conn, lobjId);
 611 }
 612
 613
 614 unsigned int
 615 pg_db_lo_import (dbh, filename)
 616     SV *dbh;
 617     char *filename;
 618 {
 619     D_imp_dbh(dbh);
 620     return lo_import(imp_dbh->conn, filename);
 621 }
 622
 623
 624 int
 625 pg_db_lo_export (dbh, lobjId, filename)
 626     SV *dbh;
 627     unsigned int lobjId;
 628     char *filename;
 629 {
 630     D_imp_dbh(dbh);
 631     return lo_export(imp_dbh->conn, lobjId, filename);
 632 }
 633
 634
 635 int
 636 pg_db_putline (dbh, buffer)
 637     SV *dbh;
 638     char *buffer;
 639 {
 640     D_imp_dbh(dbh);
 641     return PQputline(imp_dbh->conn, buffer);
 642 }
 643
 644
 645 int
 646 pg_db_getline (dbh, buffer, length)
 647     SV *dbh;
 648     char *buffer;
 649     int length;
 650 {
 651     D_imp_dbh(dbh);
 652     return PQgetline(imp_dbh->conn, buffer, length);
 653 }
 654
 655
 656 int
 657 pg_db_endcopy (dbh)
 658     SV *dbh;
 659 {
 660     D_imp_dbh(dbh);
 661     return PQendcopy(imp_dbh->conn);
 662 }
 663
 664
 665 /* ================================================================== */
 666
 667
 668 int
 669 dbd_st_prepare (sth, imp_sth, statement, attribs)
 670     SV *sth;
 671     imp_sth_t *imp_sth;
 672     char *statement;
 673     SV *attribs;
 674 {
 675     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_prepare: statement = >%s<\n", statement); }
 676
 677     /* scan statement for '?', ':1' and/or ':foo' style placeholders */
 678     dbd_preparse(imp_sth, statement);
 679
 680     /* initialize new statement handle */
 681     imp_sth->result    = 0;
 682     imp_sth->cur_tuple = 0;
 683
 684     DBIc_IMPSET_on(imp_sth);
 685     return 1;
 686 }
 687
 688
 689 static void
 690 dbd_preparse (imp_sth, statement)
 691     imp_sth_t *imp_sth;
 692     char *statement;
 693 {
 694     bool in_literal = FALSE;
 695     char in_comment = '\0';
 696     char *src, *start, *dest;
 697     phs_t phs_tpl;
 698     SV *phs_sv;
 699     int idx=0;
 700     char *style="", *laststyle=Nullch;
 701     STRLEN namelen;
 702
 703     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_preparse: statement = >%s<\n", statement); }
 704
 705     /* allocate room for copy of statement with spare capacity  */
 706     /* for editing '?' or ':1' into ':p1'.                      */
 707     /*                                                          */
 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);
 713
 714     /* initialise phs ready to be cloned per placeholder        */
 715     memset(&phs_tpl, 0, sizeof(phs_tpl));
 716     phs_tpl.ftype = 1043;       /* VARCHAR */
 717
 718     src  = statement;
 719     dest = imp_sth->statement;
 720     while(*src) {
 721
 722         if (in_comment) {
 723             /* SQL-style and C++-style */
 724             if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
 725                 in_comment = '\0';
 726             }
 727             /* C-style */
 728             else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
 729                 *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
 730                 in_comment = '\0';
 731             }
 732             *dest++ = *src++;
 733             continue;
 734         }
 735
 736         if (in_literal) {
 737             /* check if literal ends but keep quotes in literal */
 738             if (*src == in_literal) {
 739                 int bs=0;
 740                 char *str;
 741                 str = src-1;
 742                 while (*(str-bs) == '\\')
 743                 bs++;
 744                 if (!(bs & 1))
 745                     in_literal = 0;
 746             }
 747             *dest++ = *src++;
 748             continue;
 749         }
 750
 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) == '*'))
 755         {
 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. */
 760             *dest++ = *src++;
 761             *dest++ = *src++;
 762             continue;
 763         }
 764
 765         /* check if no placeholders */
 766         if (*src != ':' && *src != '?') {
 767             if (*src == '\'' || *src == '"') {
 768                 in_literal = *src;
 769             }
 770             *dest++ = *src++;
 771             continue;
 772         }
 773
 774         /* check for cast operator */
 775         if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
 776             *dest++ = *src++;
 777             continue;
 778         }
 779
 780         /* only here for : or ? outside of a comment or literal and no cast */
 781
 782         start = dest;                   /* save name inc colon  */
 783         *dest++ = *src++;
 784         if (*start == '?') {            /* X/Open standard      */
 785             sprintf(start,":p%d", ++idx); /* '?' -> ':p1' (etc) */
 786             dest = start+strlen(start);
 787             style = "?";
 788
 789         } else if (isDIGIT(*src)) {     /* ':1'         */
 790             idx = atoi(src);
 791             *dest++ = 'p';              /* ':1'->':p1'  */
 792             if (idx <= 0) {
 793                 croak("Placeholder :%d invalid, placeholders must be >= 1", idx);
 794             }
 795             while(isDIGIT(*src)) {
 796                 *dest++ = *src++;
 797             }
 798             style = ":1";
 799
 800         } else if (isALNUM(*src)) {     /* ':foo'       */
 801             while(isALNUM(*src)) {      /* includes '_' */
 802                 *dest++ = *src++;
 803             }
 804             style = ":foo";
 805         } else {                        /* perhaps ':=' PL/SQL construct */
 806             continue;
 807         }
 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);
 812         }
 813         laststyle = style;
 814         if (imp_sth->all_params_hv == NULL) {
 815             imp_sth->all_params_hv = newHV();
 816         }
 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);
 821     }
 822     *dest = '\0';
 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)); }
 826     }
 827 }
 828
 829
 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)
 832     int sql_type;
 833 {
 834     if (sql_type > 1000 || sql_type == 17 || sql_type == 25 ) {
 835         return 1;
 836     }
 837     return 0;
 838 }
 839
 840
 841
 842 static int
 843 pg_sql_type (imp_sth, name, sql_type)
 844     imp_sth_t *imp_sth;
 845     char *name;
 846     int sql_type;
 847 {
 848     switch (sql_type) {
 849         case SQL_CHAR:
 850             return 1042;        /* bpchar */
 851         case SQL_NUMERIC:
 852             return 700;         /* float4 */
 853         case SQL_DECIMAL:
 854             return 700;         /* float4 */
 855         case SQL_INTEGER:
 856             return 23;          /* int4 */
 857         case SQL_SMALLINT:
 858             return 21;          /* int2 */
 859         case SQL_FLOAT:
 860             return 700;         /* float4 */
 861         case SQL_REAL:
 862             return 701;         /* float8 */
 863         case SQL_DOUBLE:
 864             return 20;          /* int8 */
 865         case SQL_VARCHAR:
 866             return 1043;        /* varchar */
 867         case SQL_BINARY:
 868             return 17;          /* bytea */
 869         default:
 870             if (DBIc_WARN(imp_sth) && imp_sth && name) {
 871                 warn("SQL type %d for '%s' is not fully supported, bound as VARCHAR instead",
 872                                                 sql_type, name);
 873             }
 874             return pg_sql_type(imp_sth, name, SQL_VARCHAR);
 875     }
 876 }
 877
 878 static int
 879 sql_pg_type (imp_sth, name, sql_type)
 880     imp_sth_t *imp_sth;
 881     char *name;
 882     int sql_type;
 883 {
 884     if (dbis->debug >= 1) {
 885                 PerlIO_printf(DBILOGFP, "sql_pg_type name '%s' type '%d'\n", name, sql_type );
 886         }
 887
 888     switch (sql_type) {
 889         case   17:              /* bytea */
 890                 return SQL_BINARY;
 891         case   20:              /* int8 */
 892                 return SQL_DOUBLE;
 893         case   21:              /* int2 */
 894                 return SQL_SMALLINT;
 895         case   23:              /* int4 */
 896                 return SQL_INTEGER;
 897         case  700:              /* float4 */
 898                 return SQL_NUMERIC;
 899         case  701:              /* float8 */
 900                 return SQL_REAL;
 901         case 1042:      /* bpchar */
 902                 return SQL_CHAR;
 903         case 1043:      /* varchar */
 904                 return SQL_VARCHAR;
 905         case 1082:      /* date */
 906                 return SQL_DATE;
 907         case 1083:      /* time */
 908                 return SQL_TIME;
 909         case 1296:      /* date */
 910                 return SQL_TIMESTAMP;
 911
 912         default:
 913                         return sql_type;
 914     }
 915 }
 916
 917
 918 static int
 919 dbd_rebind_ph (sth, imp_sth, phs)
 920     SV *sth;
 921     imp_sth_t *imp_sth;
 922     phs_t *phs;
 923 {
 924     STRLEN value_len;
 925
 926     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rebind\n"); }
 927
 928     /* convert to a string ASAP */
 929     if (!SvPOK(phs->sv) && SvOK(phs->sv)) {
 930         sv_2pv(phs->sv, &na);
 931     }
 932
 933     if (dbis->debug >= 2) {
 934         char *val = neatsvpv(phs->sv,0);
 935         PerlIO_printf(DBILOGFP, "       bind %s <== %.1000s (", phs->name, val);
 936         if (SvOK(phs->sv)) {
 937              PerlIO_printf(DBILOGFP, "size %ld/%ld/%ld, ", (long)SvCUR(phs->sv),(long)SvLEN(phs->sv),phs->maxlen);
 938         } else {
 939             PerlIO_printf(DBILOGFP, "NULL, ");
 940         }
 941         PerlIO_printf(DBILOGFP, "ptype %d, otype %d%s)\n", (int)SvTYPE(phs->sv), phs->ftype, (phs->is_inout) ? ", inout" : "");
 942     }
 943
 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.        */
 947
 948     if (phs->is_inout) {        /* XXX */
 949         if (SvREADONLY(phs->sv)) {
 950             croak(no_modify);
 951         }
 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);
 957     }
 958     else {
 959         /* phs->sv is copy of real variable, upgrade to at least string */
 960         (void)SvUPGRADE(phs->sv, SVt_PV);
 961     }
 962
 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.                */
 966     if (SvOK(phs->sv)) {
 967         phs->progv = SvPV(phs->sv, value_len);
 968         phs->indp  = 0;
 969     }
 970     else {        /* it's null but point to buffer in case it's an out var */
 971         phs->progv = SvPVX(phs->sv);
 972         phs->indp  = -1;
 973         value_len  = 0;
 974     }
 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     */
 978         phs->maxlen = 0;
 979     }
 980
 981     phs->alen = value_len + phs->alen_incnull;
 982
 983     imp_sth->all_params_len += SvOK(phs->sv) ? phs->alen : 4; /* NULL */
 984
 985     if (dbis->debug >= 3) {
 986         PerlIO_printf(DBILOGFP, "       bind %s <== '%.*s' (size %ld/%ld, otype %d, indp %d)\n",
 987             phs->name,
 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);
 991     }
 992
 993     return 1;
 994 }
 995
 996
 997 void dereference(value)
 998 SV** value;
 999 {
1000        AV* buf;
1001        SV* val;
1002           char *src;
1003        int is_ref;
1004           STRLEN len;
1005
1006        if (SvTYPE(SvRV(*value)) != SVt_PVAV)
1007                croak("Not an array reference (%s)", neatsvpv(*value,0));
1008
1009        buf = (AV *) SvRV(*value);
1010        sv_setpv(*value, "{");
1011                while ( SvOK(val = av_shift(buf)) ) {
1012                        is_ref = SvROK(val);
1013                        if (is_ref)
1014                                dereference(&val);
1015                        else
1016                                sv_catpv(*value, "\"");
1017                        /* Quote */
1018                        src = SvPV(val, len);
1019                        while (len--) {
1020                                if (!is_ref && *src == '\"')
1021                                        sv_catpv(*value, "\\");
1022                                sv_catpvn(*value, src++, 1);
1023                        }
1024                        /* End of quote */
1025                        if (!is_ref)
1026                                sv_catpv(*value, "\"");
1027                        if (av_len(buf) > -1)
1028                                        sv_catpv(*value, array_delimiter);
1029                }
1030        sv_catpv(*value, "}");
1031        av_clear(buf);
1032 }
1033
1034 int
1035 dbd_bind_ph (sth, imp_sth, ph_namesv, newvalue, sql_type, attribs, is_inout, maxlen)
1036     SV *sth;
1037     imp_sth_t *imp_sth;
1038     SV *ph_namesv;
1039     SV *newvalue;
1040     IV sql_type;
1041     SV *attribs;
1042     int is_inout;
1043     IV maxlen;
1044 {
1045     SV **phs_svp;
1046     STRLEN name_len;
1047     char *name;
1048     char namebuf[30];
1049     phs_t *phs;
1050
1051     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_bind_ph\n"); }
1052
1053     /* check if placeholder was passed as a number        */
1054
1055     if (SvGMAGICAL(ph_namesv)) { /* eg if from tainted expression */
1056         mg_get(ph_namesv);
1057     }
1058     if (!SvNIOKp(ph_namesv)) {
1059         name = SvPV(ph_namesv, name_len);
1060     }
1061     if (SvNIOKp(ph_namesv) || (name && isDIGIT(name[0]))) {
1062         sprintf(namebuf, ":p%d", (int)SvIV(ph_namesv));
1063         name = namebuf;
1064         name_len = strlen(name);
1065     }
1066     assert(name != Nullch);
1067
1068     if (SvTYPE(newvalue) > SVt_PVLV) { /* hook for later array logic    */
1069         croak("Can't bind a non-scalar value (%s)", neatsvpv(newvalue,0));
1070     }
1071     if (SvROK(newvalue) && !IS_DBI_HANDLE(newvalue)) {
1072         /* dbi handle allowed for cursor variables */
1073                dereference(&newvalue);
1074     }
1075     if (SvTYPE(newvalue) == SVt_PVLV && is_inout) {     /* may allow later */
1076         croak("Can't bind ``lvalue'' mode scalar as inout parameter (currently)");
1077     }
1078
1079    if (dbis->debug >= 2) {
1080         PerlIO_printf(DBILOGFP, "         bind %s <== %s (type %ld", name, neatsvpv(newvalue,0), (long)sql_type);
1081         if (is_inout) {
1082             PerlIO_printf(DBILOGFP, ", inout 0x%lx, maxlen %ld", (long)newvalue, (long)maxlen);
1083         }
1084         if (attribs) {
1085             PerlIO_printf(DBILOGFP, ", attribs: %s", neatsvpv(attribs,0));
1086         }
1087         PerlIO_printf(DBILOGFP, ")\n");
1088     }
1089
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));
1093     }
1094     phs = (phs_t*)(void*)SvPVX(*phs_svp);       /* placeholder struct   */
1095
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;
1099         if (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();
1105             }
1106             av_push(imp_sth->out_params_av, SvREFCNT_inc(*phs_svp));
1107         }
1108
1109         if (attribs) {  /* only look for pg_type on first bind of var   */
1110             SV **svp;
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);
1117                 }
1118                 if (sql_type) {
1119                     croak("Can't specify both TYPE (%d) and pg_type (%d) for %s", sql_type, pg_type, phs->name);
1120                 }
1121                 phs->ftype = pg_type;
1122             }
1123         }
1124         if (sql_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);
1128             }
1129             phs->ftype = pg_sql_type(imp_sth, phs->name, sql_type);
1130         }
1131     }   /* was first bind for this placeholder  */
1132
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);
1136     }
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);
1139     }
1140
1141     phs->maxlen = maxlen;               /* 0 if not inout               */
1142
1143     if (!is_inout) {    /* normal bind to take a (new) copy of current value    */
1144         if (phs->sv == &sv_undef) {     /* (first time bind) */
1145             phs->sv = newSV(0);
1146         }
1147         sv_setsv(phs->sv, newvalue);
1148     } else if (newvalue != phs->sv) {
1149         if (phs->sv) {
1150             SvREFCNT_dec(phs->sv);
1151         }
1152         phs->sv = SvREFCNT_inc(newvalue);       /* point to live var    */
1153     }
1154
1155     return dbd_rebind_ph(sth, imp_sth, phs);
1156 }
1157
1158
1159 int
1160 dbd_st_execute (sth, imp_sth)   /* <= -2:error, >=0:ok row count, (-1=unknown count) */
1161     SV *sth;
1162     imp_sth_t *imp_sth;
1163 {
1164     dTHR;
1165
1166     D_imp_dbh_from_sth;
1167     ExecStatusType status = -1;
1168     char *cmdStatus;
1169     char *cmdTuples;
1170     char *statement;
1171     int ret = -2;
1172     int num_fields;
1173     int i;
1174     STRLEN len;
1175     bool in_literal = FALSE;
1176     char in_comment = '\0';
1177     char *src;
1178     char *dest;
1179     char *val;
1180     char namebuf[30];
1181     phs_t *phs;
1182     SV **svp;
1183
1184     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_execute\n"); }
1185
1186     /*
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);
1191     */
1192
1193     if (NULL == imp_dbh->conn) {
1194         pg_error(sth, -1, "execute on disconnected handle");
1195         return -2;
1196     }
1197
1198     statement = imp_sth->statement;
1199     if (! statement) {
1200         /* are we prepared ? */
1201         pg_error(sth, -1, "statement not prepared\n");
1202         return -2;
1203     }
1204
1205     /* do we have input parameters ? */
1206     if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
1207         /*
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)
1213            + null terminator
1214         Note: parameters look like :p1 at this point, so there's no
1215         need to explicitly allow for surrounding quotes because '' is
1216         shorter than :p1
1217         */
1218         int max_len = strlen(imp_sth->statement) + imp_sth->all_params_len * 5 + 1;
1219         statement = (char*)safemalloc( max_len );
1220         dest = statement;
1221         src  = imp_sth->statement;
1222         /* scan statement for ':p1' style placeholders */
1223         while(*src) {
1224
1225             if (in_comment) {
1226                 /* SQL-style and C++-style */
1227                 if ((in_comment == '-' || in_comment == '/') && *src == '\n') {
1228                     in_comment = '\0';
1229                 }
1230                 /* C-style */
1231                 else if (in_comment == '*' && *src == '*' && *(src+1) == '/') {
1232                     *dest++ = *src++; /* avoids asterisk-slash-asterisk issues */
1233                     in_comment = '\0';
1234                 }
1235                 *dest++ = *src++;
1236                 continue;
1237             }
1238
1239             if (in_literal) {
1240                 /* check if literal ends but keep quotes in literal */
1241                 if (*src == in_literal) {
1242                     int bs=0;
1243                     char *str;
1244                     str = src-1;
1245                     while (*(str-bs) == '\\')
1246                     bs++;
1247                     if (!(bs & 1))
1248                         in_literal = 0;
1249                 }
1250                 *dest++ = *src++;
1251                 continue;
1252             }
1253
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) == '*'))
1258             {
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. */
1263                 *dest++ = *src++;
1264                 *dest++ = *src++;
1265                 continue;
1266             }
1267
1268             /* check if no placeholders */
1269             if (*src != ':' && *src != '?') {
1270                 if (*src == '\'' || *src == '"') {
1271                     in_literal = *src;
1272                 }
1273                 *dest++ = *src++;
1274                 continue;
1275             }
1276
1277             /* check for cast operator */
1278             if (*src == ':' && (*(src-1) == ':' || *(src+1) == ':')) {
1279                 *dest++ = *src++;
1280                 continue;
1281             }
1282
1283
1284             i = 0;
1285             namebuf[i++] = *src++; /* ':' */
1286             namebuf[i++] = *src++; /* 'p' */
1287
1288             while (isDIGIT(*src) && i < (sizeof(namebuf)-1) ) {
1289                 namebuf[i++] = *src++;
1290             }
1291             if ( i == (sizeof(namebuf) - 1)) {
1292                 pg_error(sth, -1, "namebuf buffer overrun\n");
1293                 return -2;
1294             }
1295             namebuf[i] = '\0';
1296             svp = hv_fetch(imp_sth->all_params_hv, namebuf, i, 0);
1297             if (svp == NULL) {
1298                 pg_error(sth, -1, "parameter unknown\n");
1299                 return -2;
1300             }
1301             /* get attribute */
1302             phs = (phs_t*)(void*)SvPVX(*svp);
1303             /* replace undef with NULL */
1304             if(!SvOK(phs->sv)) {
1305                 val = "NULL";
1306                 len = 4;
1307             } else {
1308                 val = SvPV(phs->sv, len);
1309             }
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  */
1312                 *dest++ = '\'';
1313             }
1314             while (len--) {
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");
1321                             return -2;
1322                         }
1323                         val++;
1324                         continue; /* do not copy the null */
1325                     }
1326                     /* escape quote */
1327                     if (*val == '\'') {
1328                             *dest++ = '\'';
1329                     }
1330                     /* escape backslash */
1331                     if (*val == '\\') {
1332                         if (phs->ftype == 17) { /* four backslashes. really. */
1333                             *dest++ = '\\';
1334                             *dest++ = '\\';
1335                             *dest++ = '\\';
1336                         } else {
1337                             *dest++ = '\\';
1338                         }
1339                     }
1340                 }
1341                 /* copy attribute to statement */
1342                 *dest++ = *val++;
1343             }
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  */
1346                 *dest++ = '\'';
1347             }
1348         }
1349         *dest = '\0';
1350     }
1351
1352     if (dbis->debug >= 2) { PerlIO_printf(DBILOGFP, "dbd_st_execute: statement = >%s<\n", statement); }
1353
1354     /* clear old result (if any) */
1355     if (imp_sth->result) {
1356         PQclear(imp_sth->result);
1357     }
1358
1359     /* execute statement */
1360     imp_sth->result = PQexec(imp_dbh->conn, statement);
1361
1362     /* free statement string in case of input parameters */
1363     if ((int)DBIc_NUM_PARAMS(imp_sth) > 0) {
1364         Safefree(statement);
1365     }
1366
1367     /* check status */
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) : "";
1371
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);
1383         } else {
1384             ret = -1;
1385         }
1386     } else if (PGRES_COPY_OUT == status || PGRES_COPY_IN == status) {
1387       /* Copy Out/In data transfer in progress */
1388         ret = -1;
1389     } else {
1390         pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1391         ret = -2;
1392     }
1393
1394     /* store the number of affected rows */
1395     imp_sth->rows = ret;
1396
1397     return ret;
1398 }
1399
1400
1401 int
1402 is_high_bit_set(val)
1403     char *val;
1404 {
1405     while (*val++)
1406         if (*val & 0x80) return 1;
1407     return 0;
1408 }
1409
1410 AV *
1411 dbd_st_fetch (sth, imp_sth)
1412     SV *sth;
1413     imp_sth_t *imp_sth;
1414 {
1415     D_imp_dbh_from_sth;
1416     int num_fields;
1417     int i;
1418     AV *av;
1419
1420     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_fetch\n"); }
1421
1422     /* Check that execute() was executed sucessfully */
1423     if ( !DBIc_ACTIVE(imp_sth) ) {
1424         pg_error(sth, 1, "no statement executing\n");
1425
1426         return Nullav;
1427     }
1428
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 */
1433     }
1434
1435     av = DBIS->get_fbav(imp_sth);
1436     num_fields = AvFILL(av)+1;
1437
1438     for(i = 0; i < num_fields; ++i) {
1439
1440         SV *sv  = AvARRAY(av)[i];
1441         if (PQgetisnull(imp_sth->result, imp_sth->cur_tuple, i)) {
1442             sv_setsv(sv, &sv_undef);
1443         } else {
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 */
1449             }
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 */
1453                 int c1,c2,c3;
1454                 while (*s) {
1455                     if (*s == '\\') {
1456                         if (*(s+1) == '\\') { /* double backslash */
1457                             *p++ = '\\';
1458                             s += 2;
1459                             continue;
1460                         }
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');
1465                             s += 4;
1466                             continue;
1467                         }
1468                     }
1469                     *p++ = *s++;
1470                 }
1471                 val_len = (p - val);
1472             }
1473             else if (1042 == type && DBIc_has(imp_sth,DBIcf_ChopBlanks)) {
1474                 char *str = val;
1475                 while((val_len > 0) && (str[val_len-1] == ' ')) {
1476                     val_len--;
1477                 }
1478                 val[val_len] = '\0';
1479             }
1480             sv_setpvn(sv, val, val_len);
1481 #ifdef SvUTF8_off
1482             if (imp_dbh->pg_enable_utf8) {
1483                 SvUTF8_off(sv);
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))
1487                         SvUTF8_on(sv);
1488                 }
1489             }
1490 #endif
1491         }
1492     }
1493
1494     imp_sth->cur_tuple += 1;
1495
1496     return av;
1497 }
1498
1499
1500 int
1501 dbd_st_blob_read (sth, imp_sth, lobjId, offset, len, destrv, destoffset)
1502     SV *sth;
1503     imp_sth_t *imp_sth;
1504     int lobjId;
1505     long offset;
1506     long len;
1507     SV *destrv;
1508     long destoffset;
1509 {
1510     D_imp_dbh_from_sth;
1511     int ret, lobj_fd, nbytes, nread;
1512     PGresult* result;
1513     ExecStatusType status;
1514     SV *bufsv;
1515     char *tmp;
1516
1517     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_blob_read\n"); }
1518     /* safety check */
1519     if (lobjId <= 0) {
1520         pg_error(sth, -1, "dbd_st_blob_read: lobjId <= 0");
1521         return 0;
1522     }
1523     if (offset < 0) {
1524         pg_error(sth, -1, "dbd_st_blob_read: offset < 0");
1525         return 0;
1526     }
1527     if (len < 0) {
1528         pg_error(sth, -1, "dbd_st_blob_read: len < 0");
1529         return 0;
1530     }
1531     if (! SvROK(destrv)) {
1532         pg_error(sth, -1, "dbd_st_blob_read: destrv not a reference");
1533         return 0;
1534     }
1535     if (destoffset < 0) {
1536         pg_error(sth, -1, "dbd_st_blob_read: destoffset < 0");
1537         return 0;
1538     }
1539
1540     /* dereference destination and ensure it's writable string */
1541     bufsv = SvRV(destrv);
1542     if (! destoffset) {
1543         sv_setpvn(bufsv, "", 0);
1544     }
1545
1546     /* execute begin
1547     result = PQexec(imp_dbh->conn, "begin");
1548     status = result ? PQresultStatus(result) : -1;
1549     PQclear(result);
1550     if (status != PGRES_COMMAND_OK) {
1551         pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1552         return 0;
1553     }
1554     */
1555
1556     /* open large object */
1557     lobj_fd = lo_open(imp_dbh->conn, lobjId, INV_READ);
1558     if (lobj_fd < 0) {
1559         pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1560         return 0;
1561     }
1562
1563     /* seek on large object */
1564     if (offset > 0) {
1565         ret = lo_lseek(imp_dbh->conn, lobj_fd, offset, SEEK_SET);
1566         if (ret < 0) {
1567             pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1568             return 0;
1569         }
1570     }
1571
1572     /* read from large object */
1573     nread = 0;
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) {
1577         nread += nbytes;
1578         /* break if user wants only a specified chunk */
1579         if (len > 0 && nread > len) {
1580             nread = len;
1581             break;
1582         }
1583         SvGROW(bufsv, destoffset + nread + BUFSIZ + 1);
1584         tmp = (SvPVX(bufsv)) + destoffset + nread;
1585     }
1586
1587     /* terminate string */
1588     SvCUR_set(bufsv, destoffset + nread);
1589     *SvEND(bufsv) = '\0';
1590
1591     /* close large object */
1592     ret = lo_close(imp_dbh->conn, lobj_fd);
1593     if (ret < 0) {
1594         pg_error(sth, -1, PQerrorMessage(imp_dbh->conn));
1595         return 0;
1596     }
1597
1598     /* execute end
1599     result = PQexec(imp_dbh->conn, "end");
1600     status = result ? PQresultStatus(result) : -1;
1601     PQclear(result);
1602     if (status != PGRES_COMMAND_OK) {
1603         pg_error(sth, status, PQerrorMessage(imp_dbh->conn));
1604         return 0;
1605     }
1606     */
1607
1608     return nread;
1609 }
1610
1611
1612 int
1613 dbd_st_rows (sth, imp_sth)
1614     SV *sth;
1615     imp_sth_t *imp_sth;
1616 {
1617     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_rows\n"); }
1618
1619     return imp_sth->rows;
1620 }
1621
1622
1623 int
1624 dbd_st_finish (sth, imp_sth)
1625     SV *sth;
1626     imp_sth_t *imp_sth;
1627 {
1628     dTHR;
1629
1630     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_finish\n"); }
1631
1632     if (DBIc_ACTIVE(imp_sth) && imp_sth->result) {
1633         PQclear(imp_sth->result);
1634         imp_sth->result = 0;
1635         imp_sth->rows   = 0;
1636     }
1637
1638     DBIc_ACTIVE_off(imp_sth);
1639     return 1;
1640 }
1641
1642
1643 void
1644 dbd_st_destroy (sth, imp_sth)
1645     SV *sth;
1646     imp_sth_t *imp_sth;
1647 {
1648     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_destroy\n"); }
1649
1650     /* Free off contents of imp_sth */
1651
1652     Safefree(imp_sth->statement);
1653     if (imp_sth->result) {
1654         PQclear(imp_sth->result);
1655         imp_sth->result = 0;
1656     }
1657
1658     if (imp_sth->out_params_av)
1659         sv_free((SV*)imp_sth->out_params_av);
1660
1661     if (imp_sth->all_params_hv) {
1662         HV *hv = imp_sth->all_params_hv;
1663         SV *sv;
1664         char *key;
1665         I32 retlen;
1666         hv_iterinit(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);
1671             }
1672         }
1673         sv_free((SV*)imp_sth->all_params_hv);
1674     }
1675
1676     DBIc_IMPSET_off(imp_sth); /* let DBI know we've done it */
1677 }
1678
1679
1680 int
1681 dbd_st_STORE_attrib (sth, imp_sth, keysv, valuesv)
1682     SV *sth;
1683     imp_sth_t *imp_sth;
1684     SV *keysv;
1685     SV *valuesv;
1686 {
1687     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_STORE\n"); }
1688
1689     return FALSE;
1690 }
1691
1692
1693 SV *
1694 dbd_st_FETCH_attrib (sth, imp_sth, keysv)
1695     SV *sth;
1696     imp_sth_t *imp_sth;
1697     SV *keysv;
1698 {
1699     STRLEN kl;
1700     char *key = SvPV(keysv,kl);
1701     int i, sz;
1702     SV *retsv = Nullsv;
1703
1704     if (dbis->debug >= 1) { PerlIO_printf(DBILOGFP, "dbd_st_FETCH\n"); }
1705
1706     if (! imp_sth->result) {
1707         return Nullsv;
1708     }
1709
1710     i = DBIc_NUM_FIELDS(imp_sth);
1711
1712     if (kl == 4 && strEQ(key, "NAME")) {
1713         AV *av = newAV();
1714         retsv = newRV(sv_2mortal((SV*)av));
1715         while(--i >= 0) {
1716             av_store(av, i, newSVpv(PQfname(imp_sth->result, i),0));
1717         }
1718     } else if ( kl== 4 && strEQ(key, "TYPE")) {
1719                 /* Need to convert the Pg type to ANSI/SQL type. */
1720         AV *av = newAV();
1721         retsv = newRV(sv_2mortal((SV*)av));
1722         while(--i >= 0) {
1723             av_store(av, i, newSViv(sql_pg_type( imp_sth,
1724                                                         PQfname(imp_sth->result, i),
1725                                                                 PQftype(imp_sth->result, i))));
1726                 }
1727     } else if (kl==9 && strEQ(key, "PRECISION")) {
1728         AV *av = newAV();
1729         retsv = newRV(sv_2mortal((SV*)av));
1730         while(--i >= 0) {
1731             sz = PQfsize(imp_sth->result, i);
1732             av_store(av, i, sz > 0 ? newSViv(sz) : &sv_undef);
1733         }
1734     } else if (kl==5 && strEQ(key, "SCALE")) {
1735         AV *av = newAV();
1736         retsv = newRV(sv_2mortal((SV*)av));
1737         while(--i >= 0) {
1738             av_store(av, i, &sv_undef);
1739         }
1740     } else if (kl==8 && strEQ(key, "NULLABLE")) {
1741         AV *av = newAV();
1742         retsv = newRV(sv_2mortal((SV*)av));
1743         while(--i >= 0) {
1744             av_store(av, i, newSViv(2));
1745         }
1746     } else if (kl==10 && strEQ(key, "CursorName")) {
1747         retsv = &sv_undef;
1748     } else if (kl==11 && strEQ(key, "RowsInCache")) {
1749         retsv = &sv_undef;
1750     } else if (kl==7 && strEQ(key, "pg_size")) {
1751         AV *av = newAV();
1752         retsv = newRV(sv_2mortal((SV*)av));
1753         while(--i >= 0) {
1754             av_store(av, i, newSViv(PQfsize(imp_sth->result, i)));
1755         }
1756     } else if (kl==7 && strEQ(key, "pg_type")) {
1757         AV *av = newAV();
1758         char *type_nam;
1759         retsv = newRV(sv_2mortal((SV*)av));
1760         while(--i >= 0) {
1761             switch (PQftype(imp_sth->result, i)) {
1762             case 16:
1763                 type_nam = "bool";
1764                 break;
1765             case 17:
1766                 type_nam = "bytea";
1767                 break;
1768             case 18:
1769                 type_nam = "char";
1770                 break;
1771             case 19:
1772                 type_nam = "name";
1773                 break;
1774             case 20:
1775                 type_nam = "int8";
1776                 break;
1777             case 21:
1778                 type_nam = "int2";
1779                 break;
1780             case 22:
1781                 type_nam = "int28";
1782                 break;
1783             case 23:
1784                 type_nam = "int4";
1785                 break;
1786             case 24:
1787                 type_nam = "regproc";
1788                 break;
1789             case 25:
1790                 type_nam = "text";
1791                 break;
1792             case 26:
1793                 type_nam = "oid";
1794                 break;
1795             case 27:
1796                 type_nam = "tid";
1797                 break;
1798             case 28:
1799                 type_nam = "xid";
1800                 break;
1801             case 29:
1802                 type_nam = "cid";
1803                 break;
1804             case 30:
1805                 type_nam = "oid8";
1806                 break;
1807             case 32:
1808                 type_nam = "SET";
1809                 break;
1810             case 210:
1811                 type_nam = "smgr";
1812                 break;
1813             case 600:
1814                 type_nam = "point";
1815                 break;
1816             case 601:
1817                 type_nam = "lseg";
1818                 break;
1819             case 602:
1820                 type_nam = "path";
1821                 break;
1822             case 603:
1823                 type_nam = "box";
1824                 break;
1825             case 604:
1826                 type_nam = "polygon";
1827                 break;
1828             case 605:
1829                 type_nam = "filename";
1830                 break;
1831             case 628:
1832                 type_nam = "line";
1833                 break;
1834             case 629:
1835                 type_nam = "_line";
1836                 break;
1837             case 700:
1838                 type_nam = "float4";
1839                 break;
1840             case 701:
1841                 type_nam = "float8";
1842                 break;
1843             case 702:
1844                 type_nam = "abstime";
1845                 break;
1846             case 703:
1847                 type_nam = "reltime";
1848                 break;
1849             case 704:
1850                 type_nam = "tinterval";
1851                 break;
1852             case 705:
1853                 type_nam = "unknown";
1854                 break;
1855             case 718:
1856                 type_nam = "circle";
1857                 break;
1858             case 719:
1859                 type_nam = "_circle";
1860                 break;
1861             case 790:
1862                 type_nam = "money";
1863                 break;
1864             case 791:
1865                 type_nam = "_money";
1866                 break;
1867             case 810:
1868                 type_nam = "oidint2";
1869                 break;
1870             case 910:
1871                 type_nam = "oidint4";
1872                 break;
1873             case 911:
1874                 type_nam = "oidname";
1875                 break;
1876             case 1000:
1877                 type_nam = "_bool";
1878                 break;
1879             case 1001:
1880                 type_nam = "_bytea";
1881                 break;
1882             case 1002:
1883                 type_nam = "_char";
1884                 break;
1885             case 1003:
1886                 type_nam = "_name";
1887                 break;
1888             case 1005:
1889                 type_nam = "_int2";
1890                 break;
1891             case 1006:
1892                 type_nam = "_int28";
1893                 break;
1894             case 1007:
1895                 type_nam = "_int4";
1896                 break;
1897             case 1008:
1898                 type_nam = "_regproc";
1899                 break;
1900             case 1009:
1901                 type_nam = "_text";
1902                 break;
1903             case 1028:
1904                 type_nam = "_oid";
1905                 break;
1906             case 1010:
1907                 type_nam = "_tid";
1908                 break;
1909             case 1011:
1910                 type_nam = "_xid";
1911                 break;
1912             case 1012:
1913                 type_nam = "_cid";
1914                 break;
1915             case 1013:
1916                 type_nam = "_oid8";
1917                 break;
1918             case 1014:
1919                 type_nam = "_lock";
1920                 break;
1921             case 1015:
1922                 type_nam = "_stub";
1923                 break;
1924             case 1016:
1925                 type_nam = "_ref";
1926                 break;
1927             case 1017:
1928                 type_nam = "_point";
1929                 break;
1930             case 1018:
1931                 type_nam = "_lseg";
1932                 break;
1933             case 1019:
1934                 type_nam = "_path";
1935                 break;
1936             case 1020:
1937                 type_nam = "_box";
1938                 break;
1939             case 1021:
1940                 type_nam = "_float4";
1941                 break;
1942             case 1022:
1943                 type_nam = "_float8";
1944                 break;
1945             case 1023:
1946                 type_nam = "_abstime";
1947                 break;
1948             case 1024:
1949                 type_nam = "_reltime";
1950                 break;
1951             case 1025:
1952                 type_nam = "_tinterval";
1953                 break;
1954             case 1026:
1955                 type_nam = "_filename";
1956                 break;
1957             case 1027:
1958                 type_nam = "_polygon";
1959                 break;
1960             case 1033:
1961                 type_nam = "aclitem";
1962                 break;
1963             case 1034:
1964                 type_nam = "_aclitem";
1965                 break;
1966             case 1042:
1967                 type_nam = "bpchar";
1968                 break;
1969             case 1043:
1970                 type_nam = "varchar";
1971                 break;
1972             case 1082:
1973                 type_nam = "date";
1974                 break;
1975             case 1083:
1976                 type_nam = "time";
1977                 break;
1978             case 1182:
1979                 type_nam = "_date";
1980                 break;
1981             case 1183:
1982                 type_nam = "_time";
1983                 break;
1984             case 1184:
1985                 type_nam = "datetime";
1986                 break;
1987             case 1185:
1988                 type_nam = "_datetime";
1989                 break;
1990             case 1186:
1991                 type_nam = "timespan";
1992                 break;
1993             case 1187:
1994                 type_nam = "_timespan";
1995                 break;
1996             case 1231:
1997                 type_nam = "_numeric";
1998                 break;
1999             case 1296:
2000                 type_nam = "timestamp";
2001                 break;
2002             case 1700:
2003                 type_nam = "numeric";
2004                 break;
2005
2006             default:
2007                 type_nam = "unknown";
2008
2009             }
2010             av_store(av, i, newSVpv(type_nam, 0));
2011         }
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);
2016     } else {
2017         return Nullsv;
2018     }
2019
2020     return sv_2mortal(retsv);
2021 }
2022
2023
2024 /* end of dbdimp.c */