granicus.if.org Git - postgresql/blob - src/pl/plperl/plperl.c

   1 /**********************************************************************
   2  * plperl.c - perl as a procedural language for PostgreSQL
   3  *
   4  * IDENTIFICATION
   5  *
   6  *        This software is copyrighted by Mark Hollomon
   7  *        but is shamelessly cribbed from pltcl.c by Jan Wieck.
   8  *
   9  *        The author hereby grants permission  to  use,  copy,  modify,
  10  *        distribute,  and      license this software and its documentation
  11  *        for any purpose, provided that existing copyright notices are
  12  *        retained      in      all  copies  and  that  this notice is included
  13  *        verbatim in any distributions. No written agreement, license,
  14  *        or  royalty  fee      is required for any of the authorized uses.
  15  *        Modifications to this software may be  copyrighted  by  their
  16  *        author  and  need  not  follow  the licensing terms described
  17  *        here, provided that the new terms are  clearly  indicated  on
  18  *        the first page of each file where they apply.
  19  *
  20  *        IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
  21  *        PARTY  FOR  DIRECT,   INDIRECT,       SPECIAL,   INCIDENTAL,   OR
  22  *        CONSEQUENTIAL   DAMAGES  ARISING      OUT  OF  THE  USE  OF  THIS
  23  *        SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
  24  *        IF  THE  AUTHOR  HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
  25  *        DAMAGE.
  26  *
  27  *        THE  AUTHOR  AND      DISTRIBUTORS  SPECIFICALLY       DISCLAIM       ANY
  28  *        WARRANTIES,  INCLUDING,  BUT  NOT  LIMITED  TO,  THE  IMPLIED
  29  *        WARRANTIES  OF  MERCHANTABILITY,      FITNESS  FOR  A  PARTICULAR
  30  *        PURPOSE,      AND NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON
  31  *        AN "AS IS" BASIS, AND THE AUTHOR      AND  DISTRIBUTORS  HAVE  NO
  32  *        OBLIGATION   TO       PROVIDE   MAINTENANCE,   SUPPORT,  UPDATES,
  33  *        ENHANCEMENTS, OR MODIFICATIONS.
  34  *
  35  * IDENTIFICATION
  36  *        $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.104 2006/03/05 16:40:51 adunstan Exp $
  37  *
  38  **********************************************************************/
  39
  40 #include "postgres.h"
  41 /* Defined by Perl */
  42 #undef _
  43
  44 /* system stuff */
  45 #include <ctype.h>
  46 #include <fcntl.h>
  47 #include <unistd.h>
  48 #include <locale.h>
  49
  50 /* postgreSQL stuff */
  51 #include "commands/trigger.h"
  52 #include "executor/spi.h"
  53 #include "funcapi.h"
  54 #include "utils/lsyscache.h"
  55 #include "utils/memutils.h"
  56 #include "utils/typcache.h"
  57 #include "miscadmin.h"
  58 #include "mb/pg_wchar.h"
  59 #include "parser/parse_type.h"
  60
  61 /* define this before the perl headers get a chance to mangle DLLIMPORT */
  62 extern DLLIMPORT bool check_function_bodies;
  63
  64 /* perl stuff */
  65 #include "plperl.h"
  66
  67 /**********************************************************************
  68  * The information we cache about loaded procedures
  69  **********************************************************************/
  70 typedef struct plperl_proc_desc
  71 {
  72         char       *proname;
  73         TransactionId fn_xmin;
  74         CommandId       fn_cmin;
  75         bool            fn_readonly;
  76         bool            lanpltrusted;
  77         bool            fn_retistuple;  /* true, if function returns tuple */
  78         bool            fn_retisset;    /* true, if function returns set */
  79         bool            fn_retisarray;  /* true if function returns array */
  80         Oid                     result_oid;             /* Oid of result type */
  81         FmgrInfo        result_in_func; /* I/O function and arg for result type */
  82         Oid                     result_typioparam;
  83         int                     nargs;
  84         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  85         bool            arg_is_rowtype[FUNC_MAX_ARGS];
  86         SV                 *reference;
  87 } plperl_proc_desc;
  88
  89 /*
  90  * The information we cache for the duration of a single call to a
  91  * function.
  92  */
  93 typedef struct plperl_call_data
  94 {
  95         plperl_proc_desc *prodesc;
  96         FunctionCallInfo  fcinfo;
  97         Tuplestorestate  *tuple_store;
  98         TupleDesc                 ret_tdesc;
  99         AttInMetadata    *attinmeta;
 100         MemoryContext     tmp_cxt;
 101 } plperl_call_data;
 102
 103 /**********************************************************************
 104  * The information we cache about prepared and saved plans
 105  **********************************************************************/
 106 typedef struct plperl_query_desc
 107 {
 108         char            qname[sizeof(long) * 2 + 1];
 109         void       *plan;
 110         int                     nargs;
 111         Oid                *argtypes;
 112         FmgrInfo   *arginfuncs;
 113         Oid                *argtypioparams;
 114 } plperl_query_desc;
 115
 116 /**********************************************************************
 117  * Global data
 118  **********************************************************************/
 119 static bool plperl_firstcall = true;
 120 static bool plperl_safe_init_done = false;
 121 static PerlInterpreter *plperl_interp = NULL;
 122 static HV  *plperl_proc_hash = NULL;
 123 static HV  *plperl_query_hash = NULL;
 124
 125 static bool plperl_use_strict = false;
 126
 127 /* this is saved and restored by plperl_call_handler */
 128 static plperl_call_data *current_call_data = NULL;
 129
 130 /**********************************************************************
 131  * Forward declarations
 132  **********************************************************************/
 133 static void plperl_init_all(void);
 134 static void plperl_init_interp(void);
 135
 136 Datum           plperl_call_handler(PG_FUNCTION_ARGS);
 137 Datum           plperl_validator(PG_FUNCTION_ARGS);
 138 void            plperl_init(void);
 139
 140 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 141
 142 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
 143 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 144
 145 static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
 146 static void plperl_init_shared_libs(pTHX);
 147 static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
 148
 149 /*
 150  * This routine is a crock, and so is everyplace that calls it.  The problem
 151  * is that the cached form of plperl functions/queries is allocated permanently
 152  * (mostly via malloc()) and never released until backend exit.  Subsidiary
 153  * data structures such as fmgr info records therefore must live forever
 154  * as well.  A better implementation would store all this stuff in a per-
 155  * function memory context that could be reclaimed at need.  In the meantime,
 156  * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
 157  * it might allocate, and whatever the eventual function might allocate using
 158  * fn_mcxt, will live forever too.
 159  */
 160 static void
 161 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
 162 {
 163         fmgr_info_cxt(functionId, finfo, TopMemoryContext);
 164 }
 165
 166
 167 /* Perform initialization during postmaster startup. */
 168
 169 void
 170 plperl_init(void)
 171 {
 172         if (!plperl_firstcall)
 173                 return;
 174
 175         DefineCustomBoolVariable(
 176                                                          "plperl.use_strict",
 177           "If true, will compile trusted and untrusted perl code in strict mode",
 178                                                          NULL,
 179                                                          &plperl_use_strict,
 180                                                          PGC_USERSET,
 181                                                          NULL, NULL);
 182
 183         EmitWarningsOnPlaceholders("plperl");
 184
 185         plperl_init_interp();
 186         plperl_firstcall = false;
 187 }
 188
 189
 190 /* Perform initialization during backend startup. */
 191
 192 static void
 193 plperl_init_all(void)
 194 {
 195         if (plperl_firstcall)
 196                 plperl_init();
 197
 198         /* We don't need to do anything yet when a new backend starts. */
 199 }
 200
 201 /* Each of these macros must represent a single string literal */
 202
 203 #define PERLBOOT \
 204         "SPI::bootstrap(); use vars qw(%_SHARED);" \
 205         "sub ::plperl_warn { my $msg = shift; " \
 206         "       $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
 207         "$SIG{__WARN__} = \\&::plperl_warn; " \
 208         "sub ::plperl_die { my $msg = shift; " \
 209         "       $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
 210         "$SIG{__DIE__} = \\&::plperl_die; " \
 211         "sub ::mkunsafefunc {" \
 212         "      my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
 213         "      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
 214         "use strict; " \
 215         "sub ::mk_strict_unsafefunc {" \
 216         "      my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); " \
 217         "      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; } " \
 218         "sub ::_plperl_to_pg_array {" \
 219         "  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
 220         "  my $res = ''; my $first = 1; " \
 221         "  foreach my $elem (@$arg) " \
 222         "  { " \
 223         "    $res .= ', ' unless $first; $first = undef; " \
 224         "    if (ref $elem) " \
 225         "    { " \
 226         "      $res .= _plperl_to_pg_array($elem); " \
 227         "    } " \
 228         "    elsif (defined($elem)) " \
 229         "    { " \
 230         "      my $str = qq($elem); " \
 231         "      $str =~ s/([\"\\\\])/\\\\$1/g; " \
 232         "      $res .= qq(\"$str\"); " \
 233         "    } " \
 234         "    else " \
 235         "    { "\
 236         "      $res .= 'NULL' ; " \
 237         "    } "\
 238         "  } " \
 239         "  return qq({$res}); " \
 240         "} "
 241
 242 #define SAFE_MODULE \
 243         "require Safe; $Safe::VERSION"
 244
 245 #define SAFE_OK \
 246         "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
 247         "$PLContainer->permit_only(':default');" \
 248         "$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
 249         "$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
 250         "&spi_query &spi_fetchrow &spi_cursor_close " \
 251         "&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
 252         "&_plperl_to_pg_array " \
 253         "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
 254         "sub ::mksafefunc {" \
 255         "      my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
 256         "      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
 257         "$PLContainer->permit('require'); $PLContainer->reval('use strict;');" \
 258         "$PLContainer->deny('require');" \
 259         "sub ::mk_strict_safefunc {" \
 260         "      my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
 261         "      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }"
 262
 263 #define SAFE_BAD \
 264         "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
 265         "$PLContainer->permit_only(':default');" \
 266         "$PLContainer->share(qw[&elog &ERROR ]);" \
 267         "sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
 268         "      elog(ERROR,'trusted Perl functions disabled - " \
 269         "      please upgrade Perl Safe module to version 2.09 or later');}]); }" \
 270         "sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
 271         "      elog(ERROR,'trusted Perl functions disabled - " \
 272         "      please upgrade Perl Safe module to version 2.09 or later');}]); }"
 273
 274
 275 static void
 276 plperl_init_interp(void)
 277 {
 278         static char *embedding[3] = {
 279                 "", "-e", PERLBOOT
 280         };
 281
 282 #ifdef WIN32
 283
 284         /*
 285          * The perl library on startup does horrible things like call
 286          * setlocale(LC_ALL,""). We have protected against that on most
 287          * platforms by setting the environment appropriately. However, on
 288          * Windows, setlocale() does not consult the environment, so we need
 289          * to save the existing locale settings before perl has a chance to
 290          * mangle them and restore them after its dirty deeds are done.
 291          *
 292          * MSDN ref:
 293          * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
 294          *
 295          * It appears that we only need to do this on interpreter startup, and
 296          * subsequent calls to the interpreter don't mess with the locale
 297          * settings.
 298          *
 299          * We restore them using Perl's POSIX::setlocale() function so that
 300          * Perl doesn't have a different idea of the locale from Postgres.
 301          *
 302          */
 303
 304         char *loc;
 305         char *save_collate, *save_ctype, *save_monetary, *save_numeric, *save_time;
 306         char buf[1024];
 307
 308         loc = setlocale(LC_COLLATE,NULL);
 309         save_collate = loc ? pstrdup(loc) : NULL;
 310         loc = setlocale(LC_CTYPE,NULL);
 311         save_ctype = loc ? pstrdup(loc) : NULL;
 312         loc = setlocale(LC_MONETARY,NULL);
 313         save_monetary = loc ? pstrdup(loc) : NULL;
 314         loc = setlocale(LC_NUMERIC,NULL);
 315         save_numeric = loc ? pstrdup(loc) : NULL;
 316         loc = setlocale(LC_TIME,NULL);
 317         save_time = loc ? pstrdup(loc) : NULL;
 318
 319 #endif
 320
 321         plperl_interp = perl_alloc();
 322         if (!plperl_interp)
 323                 elog(ERROR, "could not allocate Perl interpreter");
 324
 325         perl_construct(plperl_interp);
 326         perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
 327         perl_run(plperl_interp);
 328
 329         plperl_proc_hash = newHV();
 330         plperl_query_hash = newHV();
 331
 332 #ifdef WIN32
 333
 334         eval_pv("use POSIX qw(locale_h);", TRUE); /* croak on failure */
 335
 336         if (save_collate != NULL)
 337         {
 338                 snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
 339                                  "LC_COLLATE",save_collate);
 340                 eval_pv(buf,TRUE);
 341                 pfree(save_collate);
 342         }
 343         if (save_ctype != NULL)
 344         {
 345                 snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
 346                                  "LC_CTYPE",save_ctype);
 347                 eval_pv(buf,TRUE);
 348                 pfree(save_ctype);
 349         }
 350         if (save_monetary != NULL)
 351         {
 352                 snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
 353                                  "LC_MONETARY",save_monetary);
 354                 eval_pv(buf,TRUE);
 355                 pfree(save_monetary);
 356         }
 357         if (save_numeric != NULL)
 358         {
 359                 snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
 360                                  "LC_NUMERIC",save_numeric);
 361                 eval_pv(buf,TRUE);
 362                 pfree(save_numeric);
 363         }
 364         if (save_time != NULL)
 365         {
 366                 snprintf(buf, sizeof(buf),"setlocale(%s,'%s');",
 367                                  "LC_TIME",save_time);
 368                 eval_pv(buf,TRUE);
 369                 pfree(save_time);
 370         }
 371
 372 #endif
 373
 374 }
 375
 376
 377 static void
 378 plperl_safe_init(void)
 379 {
 380         SV                 *res;
 381         double          safe_version;
 382
 383         res = eval_pv(SAFE_MODULE, FALSE);      /* TRUE = croak if failure */
 384
 385         safe_version = SvNV(res);
 386
 387         /*
 388          * We actually want to reject safe_version < 2.09, but it's risky to
 389          * assume that floating-point comparisons are exact, so use a slightly
 390          * smaller comparison value.
 391          */
 392         if (safe_version < 2.0899)
 393         {
 394                 /* not safe, so disallow all trusted funcs */
 395                 eval_pv(SAFE_BAD, FALSE);
 396         }
 397         else
 398         {
 399                 eval_pv(SAFE_OK, FALSE);
 400         }
 401
 402         plperl_safe_init_done = true;
 403 }
 404
 405 /*
 406  * Perl likes to put a newline after its error messages; clean up such
 407  */
 408 static char *
 409 strip_trailing_ws(const char *msg)
 410 {
 411         char       *res = pstrdup(msg);
 412         int                     len = strlen(res);
 413
 414         while (len > 0 && isspace((unsigned char) res[len - 1]))
 415                 res[--len] = '\0';
 416         return res;
 417 }
 418
 419
 420 /* Build a tuple from a hash. */
 421
 422 static HeapTuple
 423 plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
 424 {
 425         TupleDesc       td = attinmeta->tupdesc;
 426         char      **values;
 427         SV                 *val;
 428         char       *key;
 429         I32                     klen;
 430         HeapTuple       tup;
 431
 432         values = (char **) palloc0(td->natts * sizeof(char *));
 433
 434         hv_iterinit(perlhash);
 435         while ((val = hv_iternextsv(perlhash, &key, &klen)))
 436         {
 437                 int                     attn = SPI_fnumber(td, key);
 438
 439                 if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
 440                         ereport(ERROR,
 441                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 442                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 443                                                         key)));
 444                 if (SvOK(val) && SvTYPE(val) != SVt_NULL)
 445                         values[attn - 1] = SvPV(val, PL_na);
 446         }
 447         hv_iterinit(perlhash);
 448
 449         tup = BuildTupleFromCStrings(attinmeta, values);
 450         pfree(values);
 451         return tup;
 452 }
 453
 454 /*
 455  * convert perl array to postgres string representation
 456  */
 457 static SV  *
 458 plperl_convert_to_pg_array(SV *src)
 459 {
 460         SV                 *rv;
 461         int                     count;
 462
 463         dSP;
 464
 465         PUSHMARK(SP);
 466         XPUSHs(src);
 467         PUTBACK;
 468
 469         count = call_pv("::_plperl_to_pg_array", G_SCALAR);
 470
 471         SPAGAIN;
 472
 473         if (count != 1)
 474                 elog(ERROR, "unexpected _plperl_to_pg_array failure");
 475
 476         rv = POPs;
 477
 478         PUTBACK;
 479
 480         return rv;
 481 }
 482
 483
 484 /* Set up the arguments for a trigger call. */
 485
 486 static SV  *
 487 plperl_trigger_build_args(FunctionCallInfo fcinfo)
 488 {
 489         TriggerData *tdata;
 490         TupleDesc       tupdesc;
 491         int                     i;
 492         char       *level;
 493         char       *event;
 494         char       *relid;
 495         char       *when;
 496         HV                 *hv;
 497
 498         hv = newHV();
 499
 500         tdata = (TriggerData *) fcinfo->context;
 501         tupdesc = tdata->tg_relation->rd_att;
 502
 503         relid = DatumGetCString(
 504                                                         DirectFunctionCall1(oidout,
 505                                                                   ObjectIdGetDatum(tdata->tg_relation->rd_id)
 506                                                                                                 )
 507                 );
 508
 509         hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
 510         hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
 511
 512         if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
 513         {
 514                 event = "INSERT";
 515                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 516                         hv_store(hv, "new", 3,
 517                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 518                                          0);
 519         }
 520         else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
 521         {
 522                 event = "DELETE";
 523                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 524                         hv_store(hv, "old", 3,
 525                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 526                                          0);
 527         }
 528         else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
 529         {
 530                 event = "UPDATE";
 531                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 532                 {
 533                         hv_store(hv, "old", 3,
 534                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 535                                          0);
 536                         hv_store(hv, "new", 3,
 537                                          plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc),
 538                                          0);
 539                 }
 540         }
 541         else
 542                 event = "UNKNOWN";
 543
 544         hv_store(hv, "event", 5, newSVpv(event, 0), 0);
 545         hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
 546
 547         if (tdata->tg_trigger->tgnargs > 0)
 548         {
 549                 AV                 *av = newAV();
 550
 551                 for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
 552                         av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0));
 553                 hv_store(hv, "args", 4, newRV_noinc((SV *) av), 0);
 554         }
 555
 556         hv_store(hv, "relname", 7,
 557                          newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
 558
 559         if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
 560                 when = "BEFORE";
 561         else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
 562                 when = "AFTER";
 563         else
 564                 when = "UNKNOWN";
 565         hv_store(hv, "when", 4, newSVpv(when, 0), 0);
 566
 567         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 568                 level = "ROW";
 569         else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
 570                 level = "STATEMENT";
 571         else
 572                 level = "UNKNOWN";
 573         hv_store(hv, "level", 5, newSVpv(level, 0), 0);
 574
 575         return newRV_noinc((SV *) hv);
 576 }
 577
 578
 579 /* Set up the new tuple returned from a trigger. */
 580
 581 static HeapTuple
 582 plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 583 {
 584         SV                **svp;
 585         HV                 *hvNew;
 586         HeapTuple       rtup;
 587         SV                 *val;
 588         char       *key;
 589         I32                     klen;
 590         int                     slotsused;
 591         int                *modattrs;
 592         Datum      *modvalues;
 593         char       *modnulls;
 594
 595         TupleDesc       tupdesc;
 596
 597         tupdesc = tdata->tg_relation->rd_att;
 598
 599         svp = hv_fetch(hvTD, "new", 3, FALSE);
 600         if (!svp)
 601                 ereport(ERROR,
 602                                 (errcode(ERRCODE_UNDEFINED_COLUMN),
 603                                  errmsg("$_TD->{new} does not exist")));
 604         if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
 605                 ereport(ERROR,
 606                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
 607                                  errmsg("$_TD->{new} is not a hash reference")));
 608         hvNew = (HV *) SvRV(*svp);
 609
 610         modattrs = palloc(tupdesc->natts * sizeof(int));
 611         modvalues = palloc(tupdesc->natts * sizeof(Datum));
 612         modnulls = palloc(tupdesc->natts * sizeof(char));
 613         slotsused = 0;
 614
 615         hv_iterinit(hvNew);
 616         while ((val = hv_iternextsv(hvNew, &key, &klen)))
 617         {
 618                 int                     attn = SPI_fnumber(tupdesc, key);
 619
 620                 if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
 621                         ereport(ERROR,
 622                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 623                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 624                                                         key)));
 625                 if (SvOK(val) && SvTYPE(val) != SVt_NULL)
 626                 {
 627                         Oid                     typinput;
 628                         Oid                     typioparam;
 629                         FmgrInfo        finfo;
 630
 631                         /* XXX would be better to cache these lookups */
 632                         getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid,
 633                                                          &typinput, &typioparam);
 634                         fmgr_info(typinput, &finfo);
 635                         modvalues[slotsused] = FunctionCall3(&finfo,
 636                                                                                    CStringGetDatum(SvPV(val, PL_na)),
 637                                                                                                  ObjectIdGetDatum(typioparam),
 638                                                  Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod));
 639                         modnulls[slotsused] = ' ';
 640                 }
 641                 else
 642                 {
 643                         modvalues[slotsused] = (Datum) 0;
 644                         modnulls[slotsused] = 'n';
 645                 }
 646                 modattrs[slotsused] = attn;
 647                 slotsused++;
 648         }
 649         hv_iterinit(hvNew);
 650
 651         rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
 652                                                    modattrs, modvalues, modnulls);
 653
 654         pfree(modattrs);
 655         pfree(modvalues);
 656         pfree(modnulls);
 657
 658         if (rtup == NULL)
 659                 elog(ERROR, "SPI_modifytuple failed: %s",
 660                          SPI_result_code_string(SPI_result));
 661
 662         return rtup;
 663 }
 664
 665
 666 /*
 667  * This is the only externally-visible part of the plperl call interface.
 668  * The Postgres function and trigger managers call it to execute a
 669  * perl function.
 670  */
 671 PG_FUNCTION_INFO_V1(plperl_call_handler);
 672
 673 Datum
 674 plperl_call_handler(PG_FUNCTION_ARGS)
 675 {
 676         Datum           retval;
 677         plperl_call_data *save_call_data;
 678
 679         plperl_init_all();
 680
 681         save_call_data = current_call_data;
 682         PG_TRY();
 683         {
 684                 if (CALLED_AS_TRIGGER(fcinfo))
 685                         retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
 686                 else
 687                         retval = plperl_func_handler(fcinfo);
 688         }
 689         PG_CATCH();
 690         {
 691                 current_call_data = save_call_data;
 692                 PG_RE_THROW();
 693         }
 694         PG_END_TRY();
 695
 696         current_call_data = save_call_data;
 697         return retval;
 698 }
 699
 700 /*
 701  * This is the other externally visible function - it is called when CREATE
 702  * FUNCTION is issued to validate the function being created/replaced.
 703  */
 704 PG_FUNCTION_INFO_V1(plperl_validator);
 705
 706 Datum
 707 plperl_validator(PG_FUNCTION_ARGS)
 708 {
 709         Oid                     funcoid = PG_GETARG_OID(0);
 710         HeapTuple       tuple;
 711         Form_pg_proc proc;
 712         char            functyptype;
 713         int                     numargs;
 714         Oid                *argtypes;
 715         char      **argnames;
 716         char       *argmodes;
 717         bool            istrigger = false;
 718         int                     i;
 719
 720         /* Get the new function's pg_proc entry */
 721         tuple = SearchSysCache(PROCOID,
 722                                                    ObjectIdGetDatum(funcoid),
 723                                                    0, 0, 0);
 724         if (!HeapTupleIsValid(tuple))
 725                 elog(ERROR, "cache lookup failed for function %u", funcoid);
 726         proc = (Form_pg_proc) GETSTRUCT(tuple);
 727
 728         functyptype = get_typtype(proc->prorettype);
 729
 730         /* Disallow pseudotype result */
 731         /* except for TRIGGER, RECORD, or VOID */
 732         if (functyptype == 'p')
 733         {
 734                 /* we assume OPAQUE with no arguments means a trigger */
 735                 if (proc->prorettype == TRIGGEROID ||
 736                         (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
 737                         istrigger = true;
 738                 else if (proc->prorettype != RECORDOID &&
 739                                  proc->prorettype != VOIDOID)
 740                         ereport(ERROR,
 741                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 742                                          errmsg("plperl functions cannot return type %s",
 743                                                         format_type_be(proc->prorettype))));
 744         }
 745
 746         /* Disallow pseudotypes in arguments (either IN or OUT) */
 747         numargs = get_func_arg_info(tuple,
 748                                                                 &argtypes, &argnames, &argmodes);
 749         for (i = 0; i < numargs; i++)
 750         {
 751                 if (get_typtype(argtypes[i]) == 'p')
 752                         ereport(ERROR,
 753                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 754                                          errmsg("plperl functions cannot take type %s",
 755                                                         format_type_be(argtypes[i]))));
 756         }
 757
 758         ReleaseSysCache(tuple);
 759
 760         /* Postpone body checks if !check_function_bodies */
 761         if (check_function_bodies)
 762         {
 763                 plperl_proc_desc *prodesc;
 764
 765                 plperl_init_all();
 766
 767                 prodesc = compile_plperl_function(funcoid, istrigger);
 768         }
 769
 770         /* the result of a validator is ignored */
 771         PG_RETURN_VOID();
 772 }
 773
 774
 775 /* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
 776  * supplied in s, and returns a reference to the closure. */
 777
 778 static SV  *
 779 plperl_create_sub(char *s, bool trusted)
 780 {
 781         dSP;
 782         SV                 *subref;
 783         int                     count;
 784         char       *compile_sub;
 785
 786         if (trusted && !plperl_safe_init_done)
 787         {
 788                 plperl_safe_init();
 789                 SPAGAIN;
 790         }
 791
 792         ENTER;
 793         SAVETMPS;
 794         PUSHMARK(SP);
 795         XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
 796         XPUSHs(sv_2mortal(newSVpv(s, 0)));
 797         PUTBACK;
 798
 799         /*
 800          * G_KEEPERR seems to be needed here, else we don't recognize compile
 801          * errors properly.  Perhaps it's because there's another level of eval
 802          * inside mksafefunc?
 803          */
 804
 805         if (trusted && plperl_use_strict)
 806                 compile_sub = "::mk_strict_safefunc";
 807         else if (plperl_use_strict)
 808                 compile_sub = "::mk_strict_unsafefunc";
 809         else if (trusted)
 810                 compile_sub = "::mksafefunc";
 811         else
 812                 compile_sub = "::mkunsafefunc";
 813
 814         count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
 815         SPAGAIN;
 816
 817         if (count != 1)
 818         {
 819                 PUTBACK;
 820                 FREETMPS;
 821                 LEAVE;
 822                 elog(ERROR, "didn't get a return item from mksafefunc");
 823         }
 824
 825         if (SvTRUE(ERRSV))
 826         {
 827                 (void) POPs;
 828                 PUTBACK;
 829                 FREETMPS;
 830                 LEAVE;
 831                 ereport(ERROR,
 832                                 (errcode(ERRCODE_SYNTAX_ERROR),
 833                                  errmsg("creation of Perl function failed: %s",
 834                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 835         }
 836
 837         /*
 838          * need to make a deep copy of the return. it comes off the stack as a
 839          * temporary.
 840          */
 841         subref = newSVsv(POPs);
 842
 843         if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
 844         {
 845                 PUTBACK;
 846                 FREETMPS;
 847                 LEAVE;
 848
 849                 /*
 850                  * subref is our responsibility because it is not mortal
 851                  */
 852                 SvREFCNT_dec(subref);
 853                 elog(ERROR, "didn't get a code ref");
 854         }
 855
 856         PUTBACK;
 857         FREETMPS;
 858         LEAVE;
 859
 860         return subref;
 861 }
 862
 863
 864 /**********************************************************************
 865  * plperl_init_shared_libs()            -
 866  *
 867  * We cannot use the DynaLoader directly to get at the Opcode
 868  * module (used by Safe.pm). So, we link Opcode into ourselves
 869  * and do the initialization behind perl's back.
 870  *
 871  **********************************************************************/
 872
 873 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
 874 EXTERN_C void boot_SPI(pTHX_ CV *cv);
 875
 876 static void
 877 plperl_init_shared_libs(pTHX)
 878 {
 879         char       *file = __FILE__;
 880
 881         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 882         newXS("SPI::bootstrap", boot_SPI, file);
 883 }
 884
 885
 886 static SV  *
 887 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 888 {
 889         dSP;
 890         SV                 *retval;
 891         int                     i;
 892         int                     count;
 893         SV                 *sv;
 894
 895         ENTER;
 896         SAVETMPS;
 897
 898         PUSHMARK(SP);
 899
 900         XPUSHs(&PL_sv_undef);           /* no trigger data */
 901
 902         for (i = 0; i < desc->nargs; i++)
 903         {
 904                 if (fcinfo->argnull[i])
 905                         XPUSHs(&PL_sv_undef);
 906                 else if (desc->arg_is_rowtype[i])
 907                 {
 908                         HeapTupleHeader td;
 909                         Oid                     tupType;
 910                         int32           tupTypmod;
 911                         TupleDesc       tupdesc;
 912                         HeapTupleData tmptup;
 913                         SV                 *hashref;
 914
 915                         td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
 916                         /* Extract rowtype info and find a tupdesc */
 917                         tupType = HeapTupleHeaderGetTypeId(td);
 918                         tupTypmod = HeapTupleHeaderGetTypMod(td);
 919                         tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
 920                         /* Build a temporary HeapTuple control structure */
 921                         tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
 922                         tmptup.t_data = td;
 923
 924                         hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
 925                         XPUSHs(sv_2mortal(hashref));
 926                 }
 927                 else
 928                 {
 929                         char       *tmp;
 930
 931                         tmp = DatumGetCString(FunctionCall1(&(desc->arg_out_func[i]),
 932                                                                                                 fcinfo->arg[i]));
 933                         sv = newSVpv(tmp, 0);
 934 #if PERL_BCDVERSION >= 0x5006000L
 935                         if (GetDatabaseEncoding() == PG_UTF8)
 936                                 SvUTF8_on(sv);
 937 #endif
 938                         XPUSHs(sv_2mortal(sv));
 939                         pfree(tmp);
 940                 }
 941         }
 942         PUTBACK;
 943
 944         /* Do NOT use G_KEEPERR here */
 945         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
 946
 947         SPAGAIN;
 948
 949         if (count != 1)
 950         {
 951                 PUTBACK;
 952                 FREETMPS;
 953                 LEAVE;
 954                 elog(ERROR, "didn't get a return item from function");
 955         }
 956
 957         if (SvTRUE(ERRSV))
 958         {
 959                 (void) POPs;
 960                 PUTBACK;
 961                 FREETMPS;
 962                 LEAVE;
 963                 /* XXX need to find a way to assign an errcode here */
 964                 ereport(ERROR,
 965                                 (errmsg("error from Perl function: %s",
 966                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 967         }
 968
 969         retval = newSVsv(POPs);
 970
 971         PUTBACK;
 972         FREETMPS;
 973         LEAVE;
 974
 975         return retval;
 976 }
 977
 978
 979 static SV  *
 980 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
 981                                                           SV *td)
 982 {
 983         dSP;
 984         SV                 *retval;
 985         Trigger    *tg_trigger;
 986         int                     i;
 987         int                     count;
 988
 989         ENTER;
 990         SAVETMPS;
 991
 992         PUSHMARK(sp);
 993
 994         XPUSHs(td);
 995
 996         tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
 997         for (i = 0; i < tg_trigger->tgnargs; i++)
 998                 XPUSHs(sv_2mortal(newSVpv(tg_trigger->tgargs[i], 0)));
 999         PUTBACK;
1000
1001         /* Do NOT use G_KEEPERR here */
1002         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
1003
1004         SPAGAIN;
1005
1006         if (count != 1)
1007         {
1008                 PUTBACK;
1009                 FREETMPS;
1010                 LEAVE;
1011                 elog(ERROR, "didn't get a return item from trigger function");
1012         }
1013
1014         if (SvTRUE(ERRSV))
1015         {
1016                 (void) POPs;
1017                 PUTBACK;
1018                 FREETMPS;
1019                 LEAVE;
1020                 /* XXX need to find a way to assign an errcode here */
1021                 ereport(ERROR,
1022                                 (errmsg("error from Perl trigger function: %s",
1023                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
1024         }
1025
1026         retval = newSVsv(POPs);
1027
1028         PUTBACK;
1029         FREETMPS;
1030         LEAVE;
1031
1032         return retval;
1033 }
1034
1035
1036 static Datum
1037 plperl_func_handler(PG_FUNCTION_ARGS)
1038 {
1039         plperl_proc_desc *prodesc;
1040         SV                 *perlret;
1041         Datum           retval;
1042         ReturnSetInfo *rsi;
1043         SV                 *array_ret = NULL;
1044
1045         /*
1046          * Create the call_data beforing connecting to SPI, so that it is
1047          * not allocated in the SPI memory context
1048          */
1049         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1050         current_call_data->fcinfo = fcinfo;
1051
1052         if (SPI_connect() != SPI_OK_CONNECT)
1053                 elog(ERROR, "could not connect to SPI manager");
1054
1055         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
1056         current_call_data->prodesc = prodesc;
1057
1058         rsi = (ReturnSetInfo *) fcinfo->resultinfo;
1059
1060         if (prodesc->fn_retisset)
1061         {
1062                 /* Check context before allowing the call to go through */
1063                 if (!rsi || !IsA(rsi, ReturnSetInfo) ||
1064                         (rsi->allowedModes & SFRM_Materialize) == 0 ||
1065                         rsi->expectedDesc == NULL)
1066                         ereport(ERROR,
1067                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1068                                          errmsg("set-valued function called in context that "
1069                                                         "cannot accept a set")));
1070         }
1071
1072         perlret = plperl_call_perl_func(prodesc, fcinfo);
1073
1074         /************************************************************
1075          * Disconnect from SPI manager and then create the return
1076          * values datum (if the input function does a palloc for it
1077          * this must not be allocated in the SPI memory context
1078          * because SPI_finish would free it).
1079          ************************************************************/
1080         if (SPI_finish() != SPI_OK_FINISH)
1081                 elog(ERROR, "SPI_finish() failed");
1082
1083         if (prodesc->fn_retisset)
1084         {
1085                 /*
1086                  * If the Perl function returned an arrayref, we pretend that it
1087                  * called return_next() for each element of the array, to handle old
1088                  * SRFs that didn't know about return_next(). Any other sort of return
1089                  * value is an error.
1090                  */
1091                 if (SvTYPE(perlret) == SVt_RV &&
1092                         SvTYPE(SvRV(perlret)) == SVt_PVAV)
1093                 {
1094                         int                     i = 0;
1095                         SV                **svp = 0;
1096                         AV                 *rav = (AV *) SvRV(perlret);
1097
1098                         while ((svp = av_fetch(rav, i, FALSE)) != NULL)
1099                         {
1100                                 plperl_return_next(*svp);
1101                                 i++;
1102                         }
1103                 }
1104                 else if (SvTYPE(perlret) != SVt_NULL)
1105                 {
1106                         ereport(ERROR,
1107                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
1108                                          errmsg("set-returning Perl function must return "
1109                                                         "reference to array or use return_next")));
1110                 }
1111
1112                 rsi->returnMode = SFRM_Materialize;
1113                 if (current_call_data->tuple_store)
1114                 {
1115                         rsi->setResult = current_call_data->tuple_store;
1116                         rsi->setDesc = current_call_data->ret_tdesc;
1117                 }
1118                 retval = (Datum) 0;
1119         }
1120         else if (SvTYPE(perlret) == SVt_NULL)
1121         {
1122                 /* Return NULL if Perl code returned undef */
1123                 if (rsi && IsA(rsi, ReturnSetInfo))
1124                         rsi->isDone = ExprEndResult;
1125                 fcinfo->isnull = true;
1126                 retval = (Datum) 0;
1127         }
1128         else if (prodesc->fn_retistuple)
1129         {
1130                 /* Return a perl hash converted to a Datum */
1131                 TupleDesc       td;
1132                 AttInMetadata *attinmeta;
1133                 HeapTuple       tup;
1134
1135                 if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
1136                         SvTYPE(SvRV(perlret)) != SVt_PVHV)
1137                 {
1138                         ereport(ERROR,
1139                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
1140                                          errmsg("composite-returning Perl function "
1141                                                         "must return reference to hash")));
1142                 }
1143
1144                 /* XXX should cache the attinmeta data instead of recomputing */
1145                 if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
1146                 {
1147                         ereport(ERROR,
1148                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1149                                          errmsg("function returning record called in context "
1150                                                         "that cannot accept type record")));
1151                 }
1152
1153                 attinmeta = TupleDescGetAttInMetadata(td);
1154                 tup = plperl_build_tuple_result((HV *) SvRV(perlret), attinmeta);
1155                 retval = HeapTupleGetDatum(tup);
1156         }
1157         else
1158         {
1159                 /* Return a perl string converted to a Datum */
1160                 char       *val;
1161
1162                 if (prodesc->fn_retisarray && SvROK(perlret) &&
1163                         SvTYPE(SvRV(perlret)) == SVt_PVAV)
1164                 {
1165                         array_ret = plperl_convert_to_pg_array(perlret);
1166                         SvREFCNT_dec(perlret);
1167                         perlret = array_ret;
1168                 }
1169
1170                 val = SvPV(perlret, PL_na);
1171
1172                 retval = FunctionCall3(&prodesc->result_in_func,
1173                                                            CStringGetDatum(val),
1174                                                            ObjectIdGetDatum(prodesc->result_typioparam),
1175                                                            Int32GetDatum(-1));
1176         }
1177
1178         if (array_ret == NULL)
1179                 SvREFCNT_dec(perlret);
1180
1181         current_call_data = NULL;
1182         return retval;
1183 }
1184
1185
1186 static Datum
1187 plperl_trigger_handler(PG_FUNCTION_ARGS)
1188 {
1189         plperl_proc_desc *prodesc;
1190         SV                 *perlret;
1191         Datum           retval;
1192         SV                 *svTD;
1193         HV                 *hvTD;
1194
1195         /*
1196          * Create the call_data beforing connecting to SPI, so that it is
1197          * not allocated in the SPI memory context
1198          */
1199         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1200         current_call_data->fcinfo = fcinfo;
1201
1202         /* Connect to SPI manager */
1203         if (SPI_connect() != SPI_OK_CONNECT)
1204                 elog(ERROR, "could not connect to SPI manager");
1205
1206         /* Find or compile the function */
1207         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
1208         current_call_data->prodesc = prodesc;
1209
1210         svTD = plperl_trigger_build_args(fcinfo);
1211         perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
1212         hvTD = (HV *) SvRV(svTD);
1213
1214         /************************************************************
1215         * Disconnect from SPI manager and then create the return
1216         * values datum (if the input function does a palloc for it
1217         * this must not be allocated in the SPI memory context
1218         * because SPI_finish would free it).
1219         ************************************************************/
1220         if (SPI_finish() != SPI_OK_FINISH)
1221                 elog(ERROR, "SPI_finish() failed");
1222
1223         if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL))
1224         {
1225                 /* undef result means go ahead with original tuple */
1226                 TriggerData *trigdata = ((TriggerData *) fcinfo->context);
1227
1228                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1229                         retval = (Datum) trigdata->tg_trigtuple;
1230                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1231                         retval = (Datum) trigdata->tg_newtuple;
1232                 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
1233                         retval = (Datum) trigdata->tg_trigtuple;
1234                 else
1235                         retval = (Datum) 0; /* can this happen? */
1236         }
1237         else
1238         {
1239                 HeapTuple       trv;
1240                 char       *tmp;
1241
1242                 tmp = SvPV(perlret, PL_na);
1243
1244                 if (pg_strcasecmp(tmp, "SKIP") == 0)
1245                         trv = NULL;
1246                 else if (pg_strcasecmp(tmp, "MODIFY") == 0)
1247                 {
1248                         TriggerData *trigdata = (TriggerData *) fcinfo->context;
1249
1250                         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1251                                 trv = plperl_modify_tuple(hvTD, trigdata,
1252                                                                                   trigdata->tg_trigtuple);
1253                         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1254                                 trv = plperl_modify_tuple(hvTD, trigdata,
1255                                                                                   trigdata->tg_newtuple);
1256                         else
1257                         {
1258                                 ereport(WARNING,
1259                                                 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1260                                            errmsg("ignoring modified tuple in DELETE trigger")));
1261                                 trv = NULL;
1262                         }
1263                 }
1264                 else
1265                 {
1266                         ereport(ERROR,
1267                                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1268                                          errmsg("result of Perl trigger function must be undef, "
1269                                                         "\"SKIP\" or \"MODIFY\"")));
1270                         trv = NULL;
1271                 }
1272                 retval = PointerGetDatum(trv);
1273         }
1274
1275         SvREFCNT_dec(svTD);
1276         if (perlret)
1277                 SvREFCNT_dec(perlret);
1278
1279         current_call_data = NULL;
1280         return retval;
1281 }
1282
1283
1284 static plperl_proc_desc *
1285 compile_plperl_function(Oid fn_oid, bool is_trigger)
1286 {
1287         HeapTuple       procTup;
1288         Form_pg_proc procStruct;
1289         char            internal_proname[64];
1290         int                     proname_len;
1291         plperl_proc_desc *prodesc = NULL;
1292         int                     i;
1293         SV                **svp;
1294
1295         /* We'll need the pg_proc tuple in any case... */
1296         procTup = SearchSysCache(PROCOID,
1297                                                          ObjectIdGetDatum(fn_oid),
1298                                                          0, 0, 0);
1299         if (!HeapTupleIsValid(procTup))
1300                 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1301         procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1302
1303         /************************************************************
1304          * Build our internal proc name from the function's Oid
1305          ************************************************************/
1306         if (!is_trigger)
1307                 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
1308         else
1309                 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
1310
1311         proname_len = strlen(internal_proname);
1312
1313         /************************************************************
1314          * Lookup the internal proc name in the hashtable
1315          ************************************************************/
1316         svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE);
1317         if (svp)
1318         {
1319                 bool            uptodate;
1320
1321                 prodesc = INT2PTR( plperl_proc_desc *, SvUV(*svp));
1322
1323                 /************************************************************
1324                  * If it's present, must check whether it's still up to date.
1325                  * This is needed because CREATE OR REPLACE FUNCTION can modify the
1326                  * function's pg_proc entry without changing its OID.
1327                  ************************************************************/
1328                 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
1329                                 prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
1330
1331                 if (!uptodate)
1332                 {
1333                         /* need we delete old entry? */
1334                         prodesc = NULL;
1335                 }
1336         }
1337
1338         /************************************************************
1339          * If we haven't found it in the hashtable, we analyze
1340          * the function's arguments and return type and store
1341          * the in-/out-functions in the prodesc block and create
1342          * a new hashtable entry for it.
1343          *
1344          * Then we load the procedure into the Perl interpreter.
1345          ************************************************************/
1346         if (prodesc == NULL)
1347         {
1348                 HeapTuple       langTup;
1349                 HeapTuple       typeTup;
1350                 Form_pg_language langStruct;
1351                 Form_pg_type typeStruct;
1352                 Datum           prosrcdatum;
1353                 bool            isnull;
1354                 char       *proc_source;
1355
1356                 /************************************************************
1357                  * Allocate a new procedure description block
1358                  ************************************************************/
1359                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
1360                 if (prodesc == NULL)
1361                         ereport(ERROR,
1362                                         (errcode(ERRCODE_OUT_OF_MEMORY),
1363                                          errmsg("out of memory")));
1364                 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
1365                 prodesc->proname = strdup(internal_proname);
1366                 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
1367                 prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
1368
1369                 /* Remember if function is STABLE/IMMUTABLE */
1370                 prodesc->fn_readonly =
1371                         (procStruct->provolatile != PROVOLATILE_VOLATILE);
1372
1373                 /************************************************************
1374                  * Lookup the pg_language tuple by Oid
1375                  ************************************************************/
1376                 langTup = SearchSysCache(LANGOID,
1377                                                                  ObjectIdGetDatum(procStruct->prolang),
1378                                                                  0, 0, 0);
1379                 if (!HeapTupleIsValid(langTup))
1380                 {
1381                         free(prodesc->proname);
1382                         free(prodesc);
1383                         elog(ERROR, "cache lookup failed for language %u",
1384                                  procStruct->prolang);
1385                 }
1386                 langStruct = (Form_pg_language) GETSTRUCT(langTup);
1387                 prodesc->lanpltrusted = langStruct->lanpltrusted;
1388                 ReleaseSysCache(langTup);
1389
1390                 /************************************************************
1391                  * Get the required information for input conversion of the
1392                  * return value.
1393                  ************************************************************/
1394                 if (!is_trigger)
1395                 {
1396                         typeTup = SearchSysCache(TYPEOID,
1397                                                                          ObjectIdGetDatum(procStruct->prorettype),
1398                                                                          0, 0, 0);
1399                         if (!HeapTupleIsValid(typeTup))
1400                         {
1401                                 free(prodesc->proname);
1402                                 free(prodesc);
1403                                 elog(ERROR, "cache lookup failed for type %u",
1404                                          procStruct->prorettype);
1405                         }
1406                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1407
1408                         /* Disallow pseudotype result, except VOID or RECORD */
1409                         if (typeStruct->typtype == 'p')
1410                         {
1411                                 if (procStruct->prorettype == VOIDOID ||
1412                                         procStruct->prorettype == RECORDOID)
1413                                          /* okay */ ;
1414                                 else if (procStruct->prorettype == TRIGGEROID)
1415                                 {
1416                                         free(prodesc->proname);
1417                                         free(prodesc);
1418                                         ereport(ERROR,
1419                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1420                                                          errmsg("trigger functions may only be called "
1421                                                                         "as triggers")));
1422                                 }
1423                                 else
1424                                 {
1425                                         free(prodesc->proname);
1426                                         free(prodesc);
1427                                         ereport(ERROR,
1428                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1429                                                          errmsg("plperl functions cannot return type %s",
1430                                                                         format_type_be(procStruct->prorettype))));
1431                                 }
1432                         }
1433
1434                         prodesc->result_oid = procStruct->prorettype;
1435                         prodesc->fn_retisset = procStruct->proretset;
1436                         prodesc->fn_retistuple = (typeStruct->typtype == 'c' ||
1437                                                                           procStruct->prorettype == RECORDOID);
1438
1439                         prodesc->fn_retisarray =
1440                                 (typeStruct->typlen == -1 && typeStruct->typelem);
1441
1442                         perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1443                         prodesc->result_typioparam = getTypeIOParam(typeTup);
1444
1445                         ReleaseSysCache(typeTup);
1446                 }
1447
1448                 /************************************************************
1449                  * Get the required information for output conversion
1450                  * of all procedure arguments
1451                  ************************************************************/
1452                 if (!is_trigger)
1453                 {
1454                         prodesc->nargs = procStruct->pronargs;
1455                         for (i = 0; i < prodesc->nargs; i++)
1456                         {
1457                                 typeTup = SearchSysCache(TYPEOID,
1458                                                  ObjectIdGetDatum(procStruct->proargtypes.values[i]),
1459                                                                                  0, 0, 0);
1460                                 if (!HeapTupleIsValid(typeTup))
1461                                 {
1462                                         free(prodesc->proname);
1463                                         free(prodesc);
1464                                         elog(ERROR, "cache lookup failed for type %u",
1465                                                  procStruct->proargtypes.values[i]);
1466                                 }
1467                                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1468
1469                                 /* Disallow pseudotype argument */
1470                                 if (typeStruct->typtype == 'p')
1471                                 {
1472                                         free(prodesc->proname);
1473                                         free(prodesc);
1474                                         ereport(ERROR,
1475                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1476                                                          errmsg("plperl functions cannot take type %s",
1477                                                 format_type_be(procStruct->proargtypes.values[i]))));
1478                                 }
1479
1480                                 if (typeStruct->typtype == 'c')
1481                                         prodesc->arg_is_rowtype[i] = true;
1482                                 else
1483                                 {
1484                                         prodesc->arg_is_rowtype[i] = false;
1485                                         perm_fmgr_info(typeStruct->typoutput,
1486                                                                    &(prodesc->arg_out_func[i]));
1487                                 }
1488
1489                                 ReleaseSysCache(typeTup);
1490                         }
1491                 }
1492
1493                 /************************************************************
1494                  * create the text of the anonymous subroutine.
1495                  * we do not use a named subroutine so that we can call directly
1496                  * through the reference.
1497                  ************************************************************/
1498                 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1499                                                                           Anum_pg_proc_prosrc, &isnull);
1500                 if (isnull)
1501                         elog(ERROR, "null prosrc");
1502                 proc_source = DatumGetCString(DirectFunctionCall1(textout,
1503                                                                                                                   prosrcdatum));
1504
1505                 /************************************************************
1506                  * Create the procedure in the interpreter
1507                  ************************************************************/
1508                 prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
1509                 pfree(proc_source);
1510                 if (!prodesc->reference)        /* can this happen? */
1511                 {
1512                         free(prodesc->proname);
1513                         free(prodesc);
1514                         elog(ERROR, "could not create internal procedure \"%s\"",
1515                                  internal_proname);
1516                 }
1517
1518                 hv_store(plperl_proc_hash, internal_proname, proname_len,
1519                                  newSVuv( PTR2UV( prodesc)), 0);
1520         }
1521
1522         ReleaseSysCache(procTup);
1523
1524         return prodesc;
1525 }
1526
1527
1528 /* Build a hash from all attributes of a given tuple. */
1529
1530 static SV  *
1531 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
1532 {
1533         HV                 *hv;
1534         int                     i;
1535
1536         hv = newHV();
1537
1538         for (i = 0; i < tupdesc->natts; i++)
1539         {
1540                 Datum           attr;
1541                 bool            isnull;
1542                 char       *attname;
1543                 char       *outputstr;
1544                 Oid                     typoutput;
1545                 bool            typisvarlena;
1546                 int                     namelen;
1547                 SV                 *sv;
1548
1549                 if (tupdesc->attrs[i]->attisdropped)
1550                         continue;
1551
1552                 attname = NameStr(tupdesc->attrs[i]->attname);
1553                 namelen = strlen(attname);
1554                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
1555
1556                 if (isnull)
1557                 {
1558                         /* Store (attname => undef) and move on. */
1559                         hv_store(hv, attname, namelen, newSV(0), 0);
1560                         continue;
1561                 }
1562
1563                 /* XXX should have a way to cache these lookups */
1564
1565                 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
1566                                                   &typoutput, &typisvarlena);
1567
1568                 outputstr = DatumGetCString(OidFunctionCall1(typoutput, attr));
1569
1570                 sv = newSVpv(outputstr, 0);
1571 #if PERL_BCDVERSION >= 0x5006000L
1572                 if (GetDatabaseEncoding() == PG_UTF8)
1573                         SvUTF8_on(sv);
1574 #endif
1575                 hv_store(hv, attname, namelen, sv, 0);
1576
1577                 pfree(outputstr);
1578         }
1579
1580         return newRV_noinc((SV *) hv);
1581 }
1582
1583
1584 HV *
1585 plperl_spi_exec(char *query, int limit)
1586 {
1587         HV                 *ret_hv;
1588
1589         /*
1590          * Execute the query inside a sub-transaction, so we can cope with errors
1591          * sanely
1592          */
1593         MemoryContext oldcontext = CurrentMemoryContext;
1594         ResourceOwner oldowner = CurrentResourceOwner;
1595
1596         BeginInternalSubTransaction(NULL);
1597         /* Want to run inside function's memory context */
1598         MemoryContextSwitchTo(oldcontext);
1599
1600         PG_TRY();
1601         {
1602                 int                     spi_rv;
1603
1604                 spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
1605                                                          limit);
1606                 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
1607                                                                                                  spi_rv);
1608
1609                 /* Commit the inner transaction, return to outer xact context */
1610                 ReleaseCurrentSubTransaction();
1611                 MemoryContextSwitchTo(oldcontext);
1612                 CurrentResourceOwner = oldowner;
1613
1614                 /*
1615                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
1616                  * in case it did, make sure we remain connected.
1617                  */
1618                 SPI_restore_connection();
1619         }
1620         PG_CATCH();
1621         {
1622                 ErrorData  *edata;
1623
1624                 /* Save error info */
1625                 MemoryContextSwitchTo(oldcontext);
1626                 edata = CopyErrorData();
1627                 FlushErrorState();
1628
1629                 /* Abort the inner transaction */
1630                 RollbackAndReleaseCurrentSubTransaction();
1631                 MemoryContextSwitchTo(oldcontext);
1632                 CurrentResourceOwner = oldowner;
1633
1634                 /*
1635                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
1636                  * have left us in a disconnected state.  We need this hack to return
1637                  * to connected state.
1638                  */
1639                 SPI_restore_connection();
1640
1641                 /* Punt the error to Perl */
1642                 croak("%s", edata->message);
1643
1644                 /* Can't get here, but keep compiler quiet */
1645                 return NULL;
1646         }
1647         PG_END_TRY();
1648
1649         return ret_hv;
1650 }
1651
1652
1653 static HV  *
1654 plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
1655                                                                 int status)
1656 {
1657         HV                 *result;
1658
1659         result = newHV();
1660
1661         hv_store(result, "status", strlen("status"),
1662                          newSVpv((char *) SPI_result_code_string(status), 0), 0);
1663         hv_store(result, "processed", strlen("processed"),
1664                          newSViv(processed), 0);
1665
1666         if (status == SPI_OK_SELECT)
1667         {
1668                 AV                 *rows;
1669                 SV                 *row;
1670                 int                     i;
1671
1672                 rows = newAV();
1673                 for (i = 0; i < processed; i++)
1674                 {
1675                         row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
1676                         av_push(rows, row);
1677                 }
1678                 hv_store(result, "rows", strlen("rows"),
1679                                  newRV_noinc((SV *) rows), 0);
1680         }
1681
1682         SPI_freetuptable(tuptable);
1683
1684         return result;
1685 }
1686
1687
1688 /*
1689  * Note: plperl_return_next is called both in Postgres and Perl contexts.
1690  * We report any errors in Postgres fashion (via ereport).      If called in
1691  * Perl context, it is SPI.xs's responsibility to catch the error and
1692  * convert to a Perl error.  We assume (perhaps without adequate justification)
1693  * that we need not abort the current transaction if the Perl code traps the
1694  * error.
1695  */
1696 void
1697 plperl_return_next(SV *sv)
1698 {
1699         plperl_proc_desc *prodesc;
1700         FunctionCallInfo fcinfo;
1701         ReturnSetInfo *rsi;
1702         MemoryContext old_cxt;
1703         HeapTuple       tuple;
1704
1705         if (!sv)
1706                 return;
1707
1708         prodesc = current_call_data->prodesc;
1709         fcinfo = current_call_data->fcinfo;
1710         rsi = (ReturnSetInfo *) fcinfo->resultinfo;
1711
1712         if (!prodesc->fn_retisset)
1713                 ereport(ERROR,
1714                                 (errcode(ERRCODE_SYNTAX_ERROR),
1715                                  errmsg("cannot use return_next in a non-SETOF function")));
1716
1717         if (prodesc->fn_retistuple &&
1718                 !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
1719                 ereport(ERROR,
1720                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
1721                                  errmsg("setof-composite-returning Perl function "
1722                                                 "must call return_next with reference to hash")));
1723
1724         if (!current_call_data->ret_tdesc)
1725         {
1726                 TupleDesc tupdesc;
1727
1728                 Assert(!current_call_data->tuple_store);
1729                 Assert(!current_call_data->attinmeta);
1730
1731                 /*
1732                  * This is the first call to return_next in the current
1733                  * PL/Perl function call, so memoize some lookups
1734                  */
1735                 if (prodesc->fn_retistuple)
1736                         (void) get_call_result_type(fcinfo, NULL, &tupdesc);
1737                 else
1738                         tupdesc = rsi->expectedDesc;
1739
1740                 /*
1741                  * Make sure the tuple_store and ret_tdesc are sufficiently
1742                  * long-lived.
1743                  */
1744                 old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1745
1746                 current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
1747                 current_call_data->tuple_store =
1748                         tuplestore_begin_heap(true, false, work_mem);
1749                 if (prodesc->fn_retistuple)
1750                 {
1751                         current_call_data->attinmeta =
1752                                 TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
1753                 }
1754
1755                 MemoryContextSwitchTo(old_cxt);
1756         }
1757
1758         /*
1759          * Producing the tuple we want to return requires making plenty of
1760          * palloc() allocations that are not cleaned up. Since this
1761          * function can be called many times before the current memory
1762          * context is reset, we need to do those allocations in a
1763          * temporary context.
1764          */
1765         if (!current_call_data->tmp_cxt)
1766         {
1767                 current_call_data->tmp_cxt =
1768                         AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
1769                                                                   "PL/Perl return_next temporary cxt",
1770                                                                   ALLOCSET_DEFAULT_MINSIZE,
1771                                                                   ALLOCSET_DEFAULT_INITSIZE,
1772                                                                   ALLOCSET_DEFAULT_MAXSIZE);
1773         }
1774
1775         old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
1776
1777         if (prodesc->fn_retistuple)
1778         {
1779                 tuple = plperl_build_tuple_result((HV *) SvRV(sv),
1780                                                                                   current_call_data->attinmeta);
1781         }
1782         else
1783         {
1784                 Datum           ret = (Datum) 0;
1785                 bool            isNull = true;
1786
1787                 if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
1788                 {
1789                         char       *val = SvPV(sv, PL_na);
1790
1791                         ret = FunctionCall3(&prodesc->result_in_func,
1792                                                                 PointerGetDatum(val),
1793                                                                 ObjectIdGetDatum(prodesc->result_typioparam),
1794                                                                 Int32GetDatum(-1));
1795                         isNull = false;
1796                 }
1797
1798                 tuple = heap_form_tuple(current_call_data->ret_tdesc, &ret, &isNull);
1799         }
1800
1801         /* Make sure to store the tuple in a long-lived memory context */
1802         MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1803         tuplestore_puttuple(current_call_data->tuple_store, tuple);
1804         MemoryContextSwitchTo(old_cxt);
1805
1806         MemoryContextReset(current_call_data->tmp_cxt);
1807 }
1808
1809
1810 SV *
1811 plperl_spi_query(char *query)
1812 {
1813         SV                 *cursor;
1814
1815         /*
1816          * Execute the query inside a sub-transaction, so we can cope with errors
1817          * sanely
1818          */
1819         MemoryContext oldcontext = CurrentMemoryContext;
1820         ResourceOwner oldowner = CurrentResourceOwner;
1821
1822         BeginInternalSubTransaction(NULL);
1823         /* Want to run inside function's memory context */
1824         MemoryContextSwitchTo(oldcontext);
1825
1826         PG_TRY();
1827         {
1828                 void       *plan;
1829                 Portal          portal;
1830
1831                 /* Create a cursor for the query */
1832                 plan = SPI_prepare(query, 0, NULL);
1833                 if ( plan == NULL)
1834                         elog(ERROR, "SPI_prepare() failed:%s",
1835                                 SPI_result_code_string(SPI_result));
1836
1837                 portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
1838                 SPI_freeplan( plan);
1839                 if ( portal == NULL)
1840                         elog(ERROR, "SPI_cursor_open() failed:%s",
1841                                 SPI_result_code_string(SPI_result));
1842                 cursor = newSVpv(portal->name, 0);
1843
1844                 /* Commit the inner transaction, return to outer xact context */
1845                 ReleaseCurrentSubTransaction();
1846                 MemoryContextSwitchTo(oldcontext);
1847                 CurrentResourceOwner = oldowner;
1848
1849                 /*
1850                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
1851                  * in case it did, make sure we remain connected.
1852                  */
1853                 SPI_restore_connection();
1854         }
1855         PG_CATCH();
1856         {
1857                 ErrorData  *edata;
1858
1859                 /* Save error info */
1860                 MemoryContextSwitchTo(oldcontext);
1861                 edata = CopyErrorData();
1862                 FlushErrorState();
1863
1864                 /* Abort the inner transaction */
1865                 RollbackAndReleaseCurrentSubTransaction();
1866                 MemoryContextSwitchTo(oldcontext);
1867                 CurrentResourceOwner = oldowner;
1868
1869                 /*
1870                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
1871                  * have left us in a disconnected state.  We need this hack to return
1872                  * to connected state.
1873                  */
1874                 SPI_restore_connection();
1875
1876                 /* Punt the error to Perl */
1877                 croak("%s", edata->message);
1878
1879                 /* Can't get here, but keep compiler quiet */
1880                 return NULL;
1881         }
1882         PG_END_TRY();
1883
1884         return cursor;
1885 }
1886
1887
1888 SV *
1889 plperl_spi_fetchrow(char *cursor)
1890 {
1891         SV                 *row;
1892
1893         /*
1894          * Execute the FETCH inside a sub-transaction, so we can cope with errors
1895          * sanely
1896          */
1897         MemoryContext oldcontext = CurrentMemoryContext;
1898         ResourceOwner oldowner = CurrentResourceOwner;
1899
1900         BeginInternalSubTransaction(NULL);
1901         /* Want to run inside function's memory context */
1902         MemoryContextSwitchTo(oldcontext);
1903
1904         PG_TRY();
1905         {
1906                 Portal          p = SPI_cursor_find(cursor);
1907
1908                 if (!p)
1909                 {
1910                         row = &PL_sv_undef;
1911                 }
1912                 else
1913                 {
1914                         SPI_cursor_fetch(p, true, 1);
1915                         if (SPI_processed == 0)
1916                         {
1917                                 SPI_cursor_close(p);
1918                                 row = &PL_sv_undef;
1919                         }
1920                         else
1921                         {
1922                                 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
1923                                                                                          SPI_tuptable->tupdesc);
1924                         }
1925                         SPI_freetuptable(SPI_tuptable);
1926                 }
1927
1928                 /* Commit the inner transaction, return to outer xact context */
1929                 ReleaseCurrentSubTransaction();
1930                 MemoryContextSwitchTo(oldcontext);
1931                 CurrentResourceOwner = oldowner;
1932
1933                 /*
1934                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
1935                  * in case it did, make sure we remain connected.
1936                  */
1937                 SPI_restore_connection();
1938         }
1939         PG_CATCH();
1940         {
1941                 ErrorData  *edata;
1942
1943                 /* Save error info */
1944                 MemoryContextSwitchTo(oldcontext);
1945                 edata = CopyErrorData();
1946                 FlushErrorState();
1947
1948                 /* Abort the inner transaction */
1949                 RollbackAndReleaseCurrentSubTransaction();
1950                 MemoryContextSwitchTo(oldcontext);
1951                 CurrentResourceOwner = oldowner;
1952
1953                 /*
1954                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
1955                  * have left us in a disconnected state.  We need this hack to return
1956                  * to connected state.
1957                  */
1958                 SPI_restore_connection();
1959
1960                 /* Punt the error to Perl */
1961                 croak("%s", edata->message);
1962
1963                 /* Can't get here, but keep compiler quiet */
1964                 return NULL;
1965         }
1966         PG_END_TRY();
1967
1968         return row;
1969 }
1970
1971 void
1972 plperl_spi_cursor_close(char *cursor)
1973 {
1974         Portal p = SPI_cursor_find(cursor);
1975         if (p)
1976                 SPI_cursor_close(p);
1977 }
1978
1979 SV *
1980 plperl_spi_prepare(char* query, int argc, SV ** argv)
1981 {
1982         plperl_query_desc *qdesc;
1983         void       *plan;
1984         int                     i;
1985         HeapTuple       typeTup;
1986
1987         MemoryContext oldcontext = CurrentMemoryContext;
1988         ResourceOwner oldowner = CurrentResourceOwner;
1989
1990         BeginInternalSubTransaction(NULL);
1991         MemoryContextSwitchTo(oldcontext);
1992
1993         /************************************************************
1994          * Allocate the new querydesc structure
1995          ************************************************************/
1996         qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
1997         MemSet(qdesc, 0, sizeof(plperl_query_desc));
1998         snprintf(qdesc-> qname, sizeof(qdesc-> qname), "%lx", (long) qdesc);
1999         qdesc-> nargs = argc;
2000         qdesc-> argtypes = (Oid *) malloc(argc * sizeof(Oid));
2001         qdesc-> arginfuncs = (FmgrInfo *) malloc(argc * sizeof(FmgrInfo));
2002         qdesc-> argtypioparams = (Oid *) malloc(argc * sizeof(Oid));
2003
2004         PG_TRY();
2005         {
2006                 /************************************************************
2007                  * Lookup the argument types by name in the system cache
2008                  * and remember the required information for input conversion
2009                  ************************************************************/
2010                 for (i = 0; i < argc; i++)
2011                 {
2012                         char       *argcopy;
2013                         List       *names = NIL;
2014                         ListCell   *l;
2015                         TypeName   *typename;
2016
2017                         /************************************************************
2018                          * Use SplitIdentifierString() on a copy of the type name,
2019                          * turn the resulting pointer list into a TypeName node
2020                          * and call typenameType() to get the pg_type tuple.
2021                          ************************************************************/
2022                         argcopy = pstrdup(SvPV(argv[i],PL_na));
2023                         SplitIdentifierString(argcopy, '.', &names);
2024                         typename = makeNode(TypeName);
2025                         foreach(l, names)
2026                                 typename->names = lappend(typename->names, makeString(lfirst(l)));
2027
2028                         typeTup = typenameType(typename);
2029                         qdesc->argtypes[i] = HeapTupleGetOid(typeTup);
2030                         perm_fmgr_info(((Form_pg_type) GETSTRUCT(typeTup))->typinput,
2031                                                    &(qdesc->arginfuncs[i]));
2032                         qdesc->argtypioparams[i] = getTypeIOParam(typeTup);
2033                         ReleaseSysCache(typeTup);
2034
2035                         list_free(typename->names);
2036                         pfree(typename);
2037                         list_free(names);
2038                         pfree(argcopy);
2039                 }
2040
2041                 /************************************************************
2042                  * Prepare the plan and check for errors
2043                  ************************************************************/
2044                 plan = SPI_prepare(query, argc, qdesc->argtypes);
2045
2046                 if (plan == NULL)
2047                         elog(ERROR, "SPI_prepare() failed:%s",
2048                                 SPI_result_code_string(SPI_result));
2049
2050                 /************************************************************
2051                  * Save the plan into permanent memory (right now it's in the
2052                  * SPI procCxt, which will go away at function end).
2053                  ************************************************************/
2054                 qdesc->plan = SPI_saveplan(plan);
2055                 if (qdesc->plan == NULL)
2056                         elog(ERROR, "SPI_saveplan() failed: %s",
2057                                 SPI_result_code_string(SPI_result));
2058
2059                 /* Release the procCxt copy to avoid within-function memory leak */
2060                 SPI_freeplan(plan);
2061
2062                 /* Commit the inner transaction, return to outer xact context */
2063                 ReleaseCurrentSubTransaction();
2064                 MemoryContextSwitchTo(oldcontext);
2065                 CurrentResourceOwner = oldowner;
2066                 /*
2067                  * AtEOSubXact_SPI() should not have popped any SPI context,
2068                  * but just in case it did, make sure we remain connected.
2069                  */
2070                 SPI_restore_connection();
2071         }
2072         PG_CATCH();
2073         {
2074                 ErrorData  *edata;
2075
2076                 free(qdesc-> argtypes);
2077                 free(qdesc-> arginfuncs);
2078                 free(qdesc-> argtypioparams);
2079                 free(qdesc);
2080
2081                 /* Save error info */
2082                 MemoryContextSwitchTo(oldcontext);
2083                 edata = CopyErrorData();
2084                 FlushErrorState();
2085
2086                 /* Abort the inner transaction */
2087                 RollbackAndReleaseCurrentSubTransaction();
2088                 MemoryContextSwitchTo(oldcontext);
2089                 CurrentResourceOwner = oldowner;
2090
2091                 /*
2092                  * If AtEOSubXact_SPI() popped any SPI context of the subxact,
2093                  * it will have left us in a disconnected state.  We need this
2094                  * hack to return to connected state.
2095                  */
2096                 SPI_restore_connection();
2097
2098                 /* Punt the error to Perl */
2099                 croak("%s", edata->message);
2100
2101                 /* Can't get here, but keep compiler quiet */
2102                 return NULL;
2103         }
2104         PG_END_TRY();
2105
2106         /************************************************************
2107          * Insert a hashtable entry for the plan and return
2108          * the key to the caller.
2109          ************************************************************/
2110         hv_store( plperl_query_hash, qdesc->qname, strlen(qdesc->qname), newSVuv( PTR2UV( qdesc)), 0);
2111
2112         return newSVpv( qdesc->qname, strlen(qdesc->qname));
2113 }
2114
2115 HV *
2116 plperl_spi_exec_prepared(char* query, HV * attr, int argc, SV ** argv)
2117 {
2118         HV                 *ret_hv;
2119         SV **sv;
2120         int i, limit, spi_rv;
2121         char * nulls;
2122         Datum      *argvalues;
2123         plperl_query_desc *qdesc;
2124
2125         /*
2126          * Execute the query inside a sub-transaction, so we can cope with
2127          * errors sanely
2128          */
2129         MemoryContext oldcontext = CurrentMemoryContext;
2130         ResourceOwner oldowner = CurrentResourceOwner;
2131
2132         BeginInternalSubTransaction(NULL);
2133         /* Want to run inside function's memory context */
2134         MemoryContextSwitchTo(oldcontext);
2135
2136         PG_TRY();
2137         {
2138                 /************************************************************
2139                  * Fetch the saved plan descriptor, see if it's o.k.
2140                  ************************************************************/
2141                 sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
2142                 if ( sv == NULL)
2143                         elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2144                 if ( *sv == NULL || !SvOK( *sv))
2145                         elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value corrupted");
2146
2147                 qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
2148                 if ( qdesc == NULL)
2149                         elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value vanished");
2150
2151                 if ( qdesc-> nargs != argc)
2152                         elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
2153                                 qdesc-> nargs, argc);
2154
2155                 /************************************************************
2156                  * Parse eventual attributes
2157                  ************************************************************/
2158                 limit = 0;
2159                 if ( attr != NULL)
2160                 {
2161                         sv = hv_fetch( attr, "limit", 5, 0);
2162                         if ( *sv && SvIOK( *sv))
2163                                 limit = SvIV( *sv);
2164                 }
2165                 /************************************************************
2166                  * Set up arguments
2167                  ************************************************************/
2168                 if ( argc > 0)
2169                 {
2170                         nulls = (char *)palloc( argc);
2171                         argvalues = (Datum *) palloc(argc * sizeof(Datum));
2172                         if ( nulls == NULL || argvalues == NULL)
2173                                 elog(ERROR, "spi_exec_prepared: not enough memory");
2174                 }
2175                 else
2176                 {
2177                         nulls = NULL;
2178                         argvalues = NULL;
2179                 }
2180
2181                 for ( i = 0; i < argc; i++)
2182                 {
2183                         if ( SvTYPE( argv[i]) != SVt_NULL)
2184                         {
2185                                 argvalues[i] =
2186                                         FunctionCall3( &qdesc->arginfuncs[i],
2187                                                   CStringGetDatum( SvPV( argv[i], PL_na)),
2188                                                   ObjectIdGetDatum( qdesc->argtypioparams[i]),
2189                                                   Int32GetDatum(-1)
2190                                         );
2191                                 nulls[i] = ' ';
2192                         }
2193                         else
2194                         {
2195                                 argvalues[i] = (Datum) 0;
2196                                 nulls[i] = 'n';
2197                         }
2198                 }
2199
2200                 /************************************************************
2201                  * go
2202                  ************************************************************/
2203                 spi_rv = SPI_execute_plan(qdesc-> plan, argvalues, nulls,
2204                                                          current_call_data->prodesc->fn_readonly, limit);
2205                 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
2206                                                                                                  spi_rv);
2207                 if ( argc > 0)
2208                 {
2209                         pfree( argvalues);
2210                         pfree( nulls);
2211                 }
2212
2213                 /* Commit the inner transaction, return to outer xact context */
2214                 ReleaseCurrentSubTransaction();
2215                 MemoryContextSwitchTo(oldcontext);
2216                 CurrentResourceOwner = oldowner;
2217                 /*
2218                  * AtEOSubXact_SPI() should not have popped any SPI context,
2219                  * but just in case it did, make sure we remain connected.
2220                  */
2221                 SPI_restore_connection();
2222         }
2223         PG_CATCH();
2224         {
2225                 ErrorData  *edata;
2226
2227                 /* Save error info */
2228                 MemoryContextSwitchTo(oldcontext);
2229                 edata = CopyErrorData();
2230                 FlushErrorState();
2231
2232                 /* Abort the inner transaction */
2233                 RollbackAndReleaseCurrentSubTransaction();
2234                 MemoryContextSwitchTo(oldcontext);
2235                 CurrentResourceOwner = oldowner;
2236
2237                 /*
2238                  * If AtEOSubXact_SPI() popped any SPI context of the subxact,
2239                  * it will have left us in a disconnected state.  We need this
2240                  * hack to return to connected state.
2241                  */
2242                 SPI_restore_connection();
2243
2244                 /* Punt the error to Perl */
2245                 croak("%s", edata->message);
2246
2247                 /* Can't get here, but keep compiler quiet */
2248                 return NULL;
2249         }
2250         PG_END_TRY();
2251
2252         return ret_hv;
2253 }
2254
2255 SV *
2256 plperl_spi_query_prepared(char* query, int argc, SV ** argv)
2257 {
2258         SV **sv;
2259         int i;
2260         char * nulls;
2261         Datum      *argvalues;
2262         plperl_query_desc *qdesc;
2263         SV *cursor;
2264         Portal portal = NULL;
2265
2266         /*
2267          * Execute the query inside a sub-transaction, so we can cope with
2268          * errors sanely
2269          */
2270         MemoryContext oldcontext = CurrentMemoryContext;
2271         ResourceOwner oldowner = CurrentResourceOwner;
2272
2273         BeginInternalSubTransaction(NULL);
2274         /* Want to run inside function's memory context */
2275         MemoryContextSwitchTo(oldcontext);
2276
2277         PG_TRY();
2278         {
2279                 /************************************************************
2280                  * Fetch the saved plan descriptor, see if it's o.k.
2281                  ************************************************************/
2282                 sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
2283                 if ( sv == NULL)
2284                         elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
2285                 if ( *sv == NULL || !SvOK( *sv))
2286                         elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value corrupted");
2287
2288                 qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
2289                 if ( qdesc == NULL)
2290                         elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value vanished");
2291
2292                 if ( qdesc-> nargs != argc)
2293                         elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
2294                                 qdesc-> nargs, argc);
2295
2296                 /************************************************************
2297                  * Set up arguments
2298                  ************************************************************/
2299                 if ( argc > 0)
2300                 {
2301                         nulls = (char *)palloc( argc);
2302                         argvalues = (Datum *) palloc(argc * sizeof(Datum));
2303                         if ( nulls == NULL || argvalues == NULL)
2304                                 elog(ERROR, "spi_query_prepared: not enough memory");
2305                 }
2306                 else
2307                 {
2308                         nulls = NULL;
2309                         argvalues = NULL;
2310                 }
2311
2312                 for ( i = 0; i < argc; i++)
2313                 {
2314                         if ( SvTYPE( argv[i]) != SVt_NULL)
2315                         {
2316                                 argvalues[i] =
2317                                         FunctionCall3( &qdesc->arginfuncs[i],
2318                                                   CStringGetDatum( SvPV( argv[i], PL_na)),
2319                                                   ObjectIdGetDatum( qdesc->argtypioparams[i]),
2320                                                   Int32GetDatum(-1)
2321                                         );
2322                                 nulls[i] = ' ';
2323                         }
2324                         else
2325                         {
2326                                 argvalues[i] = (Datum) 0;
2327                                 nulls[i] = 'n';
2328                         }
2329                 }
2330
2331                 /************************************************************
2332                  * go
2333                  ************************************************************/
2334                 portal = SPI_cursor_open(NULL, qdesc-> plan, argvalues, nulls,
2335                                                         current_call_data->prodesc->fn_readonly);
2336                 if ( argc > 0)
2337                 {
2338                         pfree( argvalues);
2339                         pfree( nulls);
2340                 }
2341                 if ( portal == NULL)
2342                         elog(ERROR, "SPI_cursor_open() failed:%s",
2343                                 SPI_result_code_string(SPI_result));
2344
2345                 cursor = newSVpv(portal->name, 0);
2346
2347                 /* Commit the inner transaction, return to outer xact context */
2348                 ReleaseCurrentSubTransaction();
2349                 MemoryContextSwitchTo(oldcontext);
2350                 CurrentResourceOwner = oldowner;
2351                 /*
2352                  * AtEOSubXact_SPI() should not have popped any SPI context,
2353                  * but just in case it did, make sure we remain connected.
2354                  */
2355                 SPI_restore_connection();
2356         }
2357         PG_CATCH();
2358         {
2359                 ErrorData  *edata;
2360
2361                 /* Save error info */
2362                 MemoryContextSwitchTo(oldcontext);
2363                 edata = CopyErrorData();
2364                 FlushErrorState();
2365
2366                 /* Abort the inner transaction */
2367                 RollbackAndReleaseCurrentSubTransaction();
2368                 MemoryContextSwitchTo(oldcontext);
2369                 CurrentResourceOwner = oldowner;
2370
2371                 /*
2372                  * If AtEOSubXact_SPI() popped any SPI context of the subxact,
2373                  * it will have left us in a disconnected state.  We need this
2374                  * hack to return to connected state.
2375                  */
2376                 SPI_restore_connection();
2377
2378                 /* Punt the error to Perl */
2379                 croak("%s", edata->message);
2380
2381                 /* Can't get here, but keep compiler quiet */
2382                 return NULL;
2383         }
2384         PG_END_TRY();
2385
2386         return cursor;
2387 }
2388
2389 void
2390 plperl_spi_freeplan(char *query)
2391 {
2392         SV ** sv;
2393         void * plan;
2394         plperl_query_desc *qdesc;
2395
2396         sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
2397         if ( sv == NULL)
2398                 elog(ERROR, "spi_exec_freeplan: Invalid prepared query passed");
2399         if ( *sv == NULL || !SvOK( *sv))
2400                 elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value corrupted");
2401
2402         qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
2403         if ( qdesc == NULL)
2404                 elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value vanished");
2405
2406         /*
2407         *       free all memory before SPI_freeplan, so if it dies, nothing will be left over
2408         */
2409         hv_delete(plperl_query_hash, query, strlen(query), G_DISCARD);
2410         plan = qdesc-> plan;
2411         free(qdesc-> argtypes);
2412         free(qdesc-> arginfuncs);
2413         free(qdesc-> argtypioparams);
2414         free(qdesc);
2415
2416         SPI_freeplan( plan);
2417 }