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

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