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.168 2010/02/16 21:39:52 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 "access/xact.h"
  20 #include "catalog/pg_language.h"
  21 #include "catalog/pg_proc.h"
  22 #include "catalog/pg_type.h"
  23 #include "commands/trigger.h"
  24 #include "executor/spi.h"
  25 #include "funcapi.h"
  26 #include "mb/pg_wchar.h"
  27 #include "miscadmin.h"
  28 #include "nodes/makefuncs.h"
  29 #include "parser/parse_type.h"
  30 #include "storage/ipc.h"
  31 #include "utils/builtins.h"
  32 #include "utils/fmgroids.h"
  33 #include "utils/guc.h"
  34 #include "utils/hsearch.h"
  35 #include "utils/lsyscache.h"
  36 #include "utils/memutils.h"
  37 #include "utils/syscache.h"
  38 #include "utils/typcache.h"
  39
  40 /* define our text domain for translations */
  41 #undef TEXTDOMAIN
  42 #define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
  43
  44 /* perl stuff */
  45 #include "plperl.h"
  46
  47 /* string literal macros defining chunks of perl code */
  48 #include "perlchunks.h"
  49
  50 PG_MODULE_MAGIC;
  51
  52 /**********************************************************************
  53  * The information we cache about loaded procedures
  54  **********************************************************************/
  55 typedef struct plperl_proc_desc
  56 {
  57         char       *proname;            /* user name of procedure */
  58         TransactionId fn_xmin;
  59         ItemPointerData fn_tid;
  60         bool            fn_readonly;
  61         bool            lanpltrusted;
  62         bool            fn_retistuple;  /* true, if function returns tuple */
  63         bool            fn_retisset;    /* true, if function returns set */
  64         bool            fn_retisarray;  /* true if function returns array */
  65         Oid                     result_oid;             /* Oid of result type */
  66         FmgrInfo        result_in_func; /* I/O function and arg for result type */
  67         Oid                     result_typioparam;
  68         int                     nargs;
  69         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  70         bool            arg_is_rowtype[FUNC_MAX_ARGS];
  71         SV                 *reference;
  72 } plperl_proc_desc;
  73
  74 /* hash table entry for proc desc  */
  75
  76 typedef struct plperl_proc_entry
  77 {
  78         char            proc_name[NAMEDATALEN]; /* internal name, eg
  79                                                                                  * __PLPerl_proc_39987 */
  80         plperl_proc_desc *proc_data;
  81 } plperl_proc_entry;
  82
  83 /*
  84  * The information we cache for the duration of a single call to a
  85  * function.
  86  */
  87 typedef struct plperl_call_data
  88 {
  89         plperl_proc_desc *prodesc;
  90         FunctionCallInfo fcinfo;
  91         Tuplestorestate *tuple_store;
  92         TupleDesc       ret_tdesc;
  93         AttInMetadata *attinmeta;
  94         MemoryContext tmp_cxt;
  95 } plperl_call_data;
  96
  97 /**********************************************************************
  98  * The information we cache about prepared and saved plans
  99  **********************************************************************/
 100 typedef struct plperl_query_desc
 101 {
 102         char            qname[20];
 103         void       *plan;
 104         int                     nargs;
 105         Oid                *argtypes;
 106         FmgrInfo   *arginfuncs;
 107         Oid                *argtypioparams;
 108 } plperl_query_desc;
 109
 110 /* hash table entry for query desc      */
 111
 112 typedef struct plperl_query_entry
 113 {
 114         char            query_name[NAMEDATALEN];
 115         plperl_query_desc *query_data;
 116 } plperl_query_entry;
 117
 118 /**********************************************************************
 119  * Global data
 120  **********************************************************************/
 121
 122 typedef enum
 123 {
 124         INTERP_NONE,
 125         INTERP_HELD,
 126         INTERP_TRUSTED,
 127         INTERP_UNTRUSTED,
 128         INTERP_BOTH
 129 } InterpState;
 130
 131 static InterpState interp_state = INTERP_NONE;
 132
 133 static PerlInterpreter *plperl_trusted_interp = NULL;
 134 static PerlInterpreter *plperl_untrusted_interp = NULL;
 135 static PerlInterpreter *plperl_held_interp = NULL;
 136 static OP *(*pp_require_orig)(pTHX) = NULL;
 137 static bool trusted_context;
 138 static HTAB *plperl_proc_hash = NULL;
 139 static HTAB *plperl_query_hash = NULL;
 140
 141 static bool plperl_use_strict = false;
 142 static char *plperl_on_init = NULL;
 143 static char *plperl_on_plperl_init = NULL;
 144 static char *plperl_on_plperlu_init = NULL;
 145 static bool plperl_ending = false;
 146
 147 /* this is saved and restored by plperl_call_handler */
 148 static plperl_call_data *current_call_data = NULL;
 149
 150 /**********************************************************************
 151  * Forward declarations
 152  **********************************************************************/
 153 Datum           plperl_call_handler(PG_FUNCTION_ARGS);
 154 Datum           plperl_inline_handler(PG_FUNCTION_ARGS);
 155 Datum           plperl_validator(PG_FUNCTION_ARGS);
 156 void            _PG_init(void);
 157
 158 static PerlInterpreter *plperl_init_interp(void);
 159 static void plperl_destroy_interp(PerlInterpreter **);
 160 static void plperl_fini(int code, Datum arg);
 161
 162 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 163 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
 164
 165 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 166
 167 static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
 168 static void plperl_init_shared_libs(pTHX);
 169 static void plperl_trusted_init(void);
 170 static void plperl_untrusted_init(void);
 171 static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
 172 static SV  *newSVstring(const char *str);
 173 static SV **hv_store_string(HV *hv, const char *key, SV *val);
 174 static SV **hv_fetch_string(HV *hv, const char *key);
 175 static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
 176 static SV  *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
 177 static void plperl_compile_callback(void *arg);
 178 static void plperl_exec_callback(void *arg);
 179 static void plperl_inline_callback(void *arg);
 180 static char *strip_trailing_ws(const char *msg);
 181 static OP * pp_require_safe(pTHX);
 182 static int restore_context(bool);
 183
 184 /*
 185  * Convert an SV to char * and verify the encoding via pg_verifymbstr()
 186  */
 187 static inline char *
 188 sv2text_mbverified(SV *sv)
 189 {
 190         char * val;
 191         STRLEN len;
 192
 193         /* The value returned here might include an
 194          * embedded nul byte, because perl allows such things.
 195          * That's OK, because pg_verifymbstr will choke on it,  If
 196          * we just used strlen() instead of getting perl's idea of
 197          * the length, whatever uses the "verified" value might
 198          * get something quite weird.
 199          */
 200         val = SvPV(sv, len);
 201         pg_verifymbstr(val, len, false);
 202         return val;
 203 }
 204
 205 /*
 206  * This routine is a crock, and so is everyplace that calls it.  The problem
 207  * is that the cached form of plperl functions/queries is allocated permanently
 208  * (mostly via malloc()) and never released until backend exit.  Subsidiary
 209  * data structures such as fmgr info records therefore must live forever
 210  * as well.  A better implementation would store all this stuff in a per-
 211  * function memory context that could be reclaimed at need.  In the meantime,
 212  * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
 213  * it might allocate, and whatever the eventual function might allocate using
 214  * fn_mcxt, will live forever too.
 215  */
 216 static void
 217 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
 218 {
 219         fmgr_info_cxt(functionId, finfo, TopMemoryContext);
 220 }
 221
 222
 223 /*
 224  * _PG_init()                   - library load-time initialization
 225  *
 226  * DO NOT make this static nor change its name!
 227  */
 228 void
 229 _PG_init(void)
 230 {
 231         /* Be sure we do initialization only once (should be redundant now) */
 232         static bool inited = false;
 233         HASHCTL         hash_ctl;
 234
 235         if (inited)
 236                 return;
 237
 238         pg_bindtextdomain(TEXTDOMAIN);
 239
 240         DefineCustomBoolVariable("plperl.use_strict",
 241                                                          gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
 242                                                          NULL,
 243                                                          &plperl_use_strict,
 244                                                          false,
 245                                                          PGC_USERSET, 0,
 246                                                          NULL, NULL);
 247
 248         DefineCustomStringVariable("plperl.on_init",
 249                                                         gettext_noop("Perl initialization code to execute when a perl interpreter is initialized."),
 250                                                         NULL,
 251                                                         &plperl_on_init,
 252                                                         NULL,
 253                                                         PGC_SIGHUP, 0,
 254                                                         NULL, NULL);
 255
 256         /*
 257          * plperl.on_plperl_init is currently PGC_SUSET to avoid issues whereby a user
 258          * who doesn't have USAGE privileges on the plperl language could possibly use
 259          * SET plperl.on_plperl_init='...' to influence the behaviour of any existing
 260          * plperl function that they can EXECUTE (which may be security definer).
 261          * Set http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php
 262          * and the overall thread.
 263          */
 264         DefineCustomStringVariable("plperl.on_plperl_init",
 265                                                         gettext_noop("Perl initialization code to execute once when plperl is first used."),
 266                                                         NULL,
 267                                                         &plperl_on_plperl_init,
 268                                                         NULL,
 269                                                         PGC_SUSET, 0,
 270                                                         NULL, NULL);
 271
 272         DefineCustomStringVariable("plperl.on_plperlu_init",
 273                                                         gettext_noop("Perl initialization code to execute once when plperlu is first used."),
 274                                                         NULL,
 275                                                         &plperl_on_plperlu_init,
 276                                                         NULL,
 277                                                         PGC_SUSET, 0,
 278                                                         NULL, NULL);
 279
 280         EmitWarningsOnPlaceholders("plperl");
 281
 282         MemSet(&hash_ctl, 0, sizeof(hash_ctl));
 283
 284         hash_ctl.keysize = NAMEDATALEN;
 285         hash_ctl.entrysize = sizeof(plperl_proc_entry);
 286
 287         plperl_proc_hash = hash_create("PLPerl Procedures",
 288                                                                    32,
 289                                                                    &hash_ctl,
 290                                                                    HASH_ELEM);
 291
 292         hash_ctl.entrysize = sizeof(plperl_query_entry);
 293         plperl_query_hash = hash_create("PLPerl Queries",
 294                                                                         32,
 295                                                                         &hash_ctl,
 296                                                                         HASH_ELEM);
 297
 298         plperl_held_interp = plperl_init_interp();
 299         interp_state = INTERP_HELD;
 300
 301         inited = true;
 302 }
 303
 304
 305 /*
 306  * Cleanup perl interpreters, including running END blocks.
 307  * Does not fully undo the actions of _PG_init() nor make it callable again.
 308  */
 309 static void
 310 plperl_fini(int code, Datum arg)
 311 {
 312         elog(DEBUG3, "plperl_fini");
 313
 314         /*
 315          * Indicate that perl is terminating.
 316          * Disables use of spi_* functions when running END/DESTROY code.
 317          * See check_spi_usage_allowed().
 318          * Could be enabled in future, with care, using a transaction
 319          * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
 320          */
 321         plperl_ending = true;
 322
 323         /* Only perform perl cleanup if we're exiting cleanly */
 324         if (code) {
 325                 elog(DEBUG3, "plperl_fini: skipped");
 326                 return;
 327         }
 328
 329         plperl_destroy_interp(&plperl_trusted_interp);
 330         plperl_destroy_interp(&plperl_untrusted_interp);
 331         plperl_destroy_interp(&plperl_held_interp);
 332
 333         elog(DEBUG3, "plperl_fini: done");
 334 }
 335
 336
 337 #define SAFE_MODULE \
 338         "require Safe; $Safe::VERSION"
 339
 340 /********************************************************************
 341  *
 342  * We start out by creating a "held" interpreter that we can use in
 343  * trusted or untrusted mode (but not both) as the need arises. Later, we
 344  * assign that interpreter if it is available to either the trusted or
 345  * untrusted interpreter. If it has already been assigned, and we need to
 346  * create the other interpreter, we do that if we can, or error out.
 347  */
 348
 349
 350 static void
 351 select_perl_context(bool trusted)
 352 {
 353         EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
 354
 355         /*
 356          * handle simple cases
 357          */
 358         if (restore_context(trusted))
 359                 return;
 360
 361         /*
 362          * adopt held interp if free, else create new one if possible
 363          */
 364         if (interp_state == INTERP_HELD)
 365         {
 366                 /* first actual use of a perl interpreter */
 367
 368                 if (trusted)
 369                 {
 370                         plperl_trusted_init();
 371                         plperl_trusted_interp = plperl_held_interp;
 372                         interp_state = INTERP_TRUSTED;
 373                 }
 374                 else
 375                 {
 376                         plperl_untrusted_init();
 377                         plperl_untrusted_interp = plperl_held_interp;
 378                         interp_state = INTERP_UNTRUSTED;
 379                 }
 380
 381                 /* successfully initialized, so arrange for cleanup */
 382                 on_proc_exit(plperl_fini, 0);
 383
 384         }
 385         else
 386         {
 387 #ifdef MULTIPLICITY
 388                 PerlInterpreter *plperl = plperl_init_interp();
 389                 if (trusted) {
 390                         plperl_trusted_init();
 391                         plperl_trusted_interp = plperl;
 392                 }
 393                 else {
 394                         plperl_untrusted_init();
 395                         plperl_untrusted_interp = plperl;
 396                 }
 397                 interp_state = INTERP_BOTH;
 398 #else
 399                 elog(ERROR,
 400                          "cannot allocate second Perl interpreter on this platform");
 401 #endif
 402         }
 403         plperl_held_interp = NULL;
 404         trusted_context = trusted;
 405
 406         /*
 407          * Since the timing of first use of PL/Perl can't be predicted,
 408          * any database interaction during initialization is problematic.
 409          * Including, but not limited to, security definer issues.
 410          * So we only enable access to the database AFTER on_*_init code has run.
 411          * See http://archives.postgresql.org/message-id/20100127143318.GE713@timac.local
 412          */
 413         newXS("PostgreSQL::InServer::SPI::bootstrap",
 414                 boot_PostgreSQL__InServer__SPI, __FILE__);
 415
 416         eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
 417         if (SvTRUE(ERRSV))
 418                 ereport(ERROR,
 419                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 420                                  errdetail("While executing PostgreSQL::InServer::SPI::bootstrap.")));
 421 }
 422
 423 /*
 424  * Restore previous interpreter selection, if two are active
 425  */
 426 static int
 427 restore_context(bool trusted)
 428 {
 429         if (interp_state == INTERP_BOTH ||
 430                 ( trusted && interp_state == INTERP_TRUSTED) ||
 431                 (!trusted && interp_state == INTERP_UNTRUSTED))
 432         {
 433                 if (trusted_context != trusted)
 434                 {
 435                         if (trusted) {
 436                                 PERL_SET_CONTEXT(plperl_trusted_interp);
 437                                 PL_ppaddr[OP_REQUIRE] = pp_require_safe;
 438                         }
 439                         else {
 440                                 PERL_SET_CONTEXT(plperl_untrusted_interp);
 441                                 PL_ppaddr[OP_REQUIRE] = pp_require_orig;
 442                         }
 443                         trusted_context = trusted;
 444                 }
 445                 return 1; /* context restored */
 446         }
 447
 448         return 0;     /* unable - appropriate interpreter not available */
 449 }
 450
 451 static PerlInterpreter *
 452 plperl_init_interp(void)
 453 {
 454         PerlInterpreter *plperl;
 455         static int perl_sys_init_done;
 456
 457         static char *embedding[3+2] = {
 458                 "", "-e", PLC_PERLBOOT
 459         };
 460         int                     nargs = 3;
 461
 462 #ifdef WIN32
 463
 464         /*
 465          * The perl library on startup does horrible things like call
 466          * setlocale(LC_ALL,""). We have protected against that on most platforms
 467          * by setting the environment appropriately. However, on Windows,
 468          * setlocale() does not consult the environment, so we need to save the
 469          * existing locale settings before perl has a chance to mangle them and
 470          * restore them after its dirty deeds are done.
 471          *
 472          * MSDN ref:
 473          * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
 474          *
 475          * It appears that we only need to do this on interpreter startup, and
 476          * subsequent calls to the interpreter don't mess with the locale
 477          * settings.
 478          *
 479          * We restore them using Perl's POSIX::setlocale() function so that Perl
 480          * doesn't have a different idea of the locale from Postgres.
 481          *
 482          */
 483
 484         char       *loc;
 485         char       *save_collate,
 486                            *save_ctype,
 487                            *save_monetary,
 488                            *save_numeric,
 489                            *save_time;
 490         char            buf[1024];
 491
 492         loc = setlocale(LC_COLLATE, NULL);
 493         save_collate = loc ? pstrdup(loc) : NULL;
 494         loc = setlocale(LC_CTYPE, NULL);
 495         save_ctype = loc ? pstrdup(loc) : NULL;
 496         loc = setlocale(LC_MONETARY, NULL);
 497         save_monetary = loc ? pstrdup(loc) : NULL;
 498         loc = setlocale(LC_NUMERIC, NULL);
 499         save_numeric = loc ? pstrdup(loc) : NULL;
 500         loc = setlocale(LC_TIME, NULL);
 501         save_time = loc ? pstrdup(loc) : NULL;
 502 #endif
 503
 504         if (plperl_on_init)
 505         {
 506                 embedding[nargs++] = "-e";
 507                 embedding[nargs++] = plperl_on_init;
 508         }
 509
 510         /****
 511          * The perl API docs state that PERL_SYS_INIT3 should be called before
 512          * allocating interprters. Unfortunately, on some platforms this fails
 513          * in the Perl_do_taint() routine, which is called when the platform is
 514          * using the system's malloc() instead of perl's own. Other platforms,
 515          * notably Windows, fail if PERL_SYS_INIT3 is not called. So we call it
 516          * if it's available, unless perl is using the system malloc(), which is
 517          * true when MYMALLOC is set.
 518          */
 519 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
 520         /* only call this the first time through, as per perlembed man page */
 521         if (!perl_sys_init_done)
 522         {
 523                 char       *dummy_env[1] = {NULL};
 524
 525                 PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
 526                 perl_sys_init_done = 1;
 527                 /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
 528                 dummy_env[0] = NULL;
 529         }
 530 #endif
 531
 532         plperl = perl_alloc();
 533         if (!plperl)
 534                 elog(ERROR, "could not allocate Perl interpreter");
 535
 536         PERL_SET_CONTEXT(plperl);
 537         perl_construct(plperl);
 538
 539         /* run END blocks in perl_destruct instead of perl_run */
 540         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 541
 542         /*
 543          * Record the original function for the 'require' opcode.
 544          * Ensure it's used for new interpreters.
 545          */
 546         if (!pp_require_orig)
 547                 pp_require_orig = PL_ppaddr[OP_REQUIRE];
 548         else
 549                 PL_ppaddr[OP_REQUIRE] = pp_require_orig;
 550
 551         if (perl_parse(plperl, plperl_init_shared_libs,
 552                            nargs, embedding, NULL) != 0)
 553                 ereport(ERROR,
 554                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 555                                  errcontext("While parsing perl initialization.")));
 556
 557         if (perl_run(plperl) != 0)
 558                 ereport(ERROR,
 559                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 560                                  errcontext("While running perl initialization.")));
 561
 562 #ifdef WIN32
 563
 564         eval_pv("use POSIX qw(locale_h);", TRUE);       /* croak on failure */
 565
 566         if (save_collate != NULL)
 567         {
 568                 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
 569                                  "LC_COLLATE", save_collate);
 570                 eval_pv(buf, TRUE);
 571                 pfree(save_collate);
 572         }
 573         if (save_ctype != NULL)
 574         {
 575                 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
 576                                  "LC_CTYPE", save_ctype);
 577                 eval_pv(buf, TRUE);
 578                 pfree(save_ctype);
 579         }
 580         if (save_monetary != NULL)
 581         {
 582                 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
 583                                  "LC_MONETARY", save_monetary);
 584                 eval_pv(buf, TRUE);
 585                 pfree(save_monetary);
 586         }
 587         if (save_numeric != NULL)
 588         {
 589                 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
 590                                  "LC_NUMERIC", save_numeric);
 591                 eval_pv(buf, TRUE);
 592                 pfree(save_numeric);
 593         }
 594         if (save_time != NULL)
 595         {
 596                 snprintf(buf, sizeof(buf), "setlocale(%s,'%s');",
 597                                  "LC_TIME", save_time);
 598                 eval_pv(buf, TRUE);
 599                 pfree(save_time);
 600         }
 601 #endif
 602
 603         return plperl;
 604 }
 605
 606
 607 /*
 608  * Our safe implementation of the require opcode.
 609  * This is safe because it's completely unable to load any code.
 610  * If the requested file/module has already been loaded it'll return true.
 611  * If not, it'll die.
 612  * So now "use Foo;" will work iff Foo has already been loaded.
 613  */
 614 static OP *
 615 pp_require_safe(pTHX)
 616 {
 617         dVAR; dSP;
 618         SV *sv, **svp;
 619         char *name;
 620         STRLEN len;
 621
 622     sv = POPs;
 623     name = SvPV(sv, len);
 624     if (!(name && len > 0 && *name))
 625         RETPUSHNO;
 626
 627         svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
 628         if (svp && *svp != &PL_sv_undef)
 629                 RETPUSHYES;
 630
 631         DIE(aTHX_ "Unable to load %s into plperl", name);
 632 }
 633
 634
 635 static void
 636 plperl_destroy_interp(PerlInterpreter **interp)
 637 {
 638         if (interp && *interp)
 639         {
 640                 /*
 641                  * Only a very minimal destruction is performed:
 642                  * - just call END blocks.
 643                  *
 644                  * We could call perl_destruct() but we'd need to audit its
 645                  * actions very carefully and work-around any that impact us.
 646                  * (Calling sv_clean_objs() isn't an option because it's not
 647                  * part of perl's public API so isn't portably available.)
 648                  * Meanwhile END blocks can be used to perform manual cleanup.
 649                  */
 650
 651                 PERL_SET_CONTEXT(*interp);
 652
 653                 /* Run END blocks - based on perl's perl_destruct() */
 654                 if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
 655                         dJMPENV;
 656                         int x = 0;
 657
 658                         JMPENV_PUSH(x);
 659                         PERL_UNUSED_VAR(x);
 660                         if (PL_endav && !PL_minus_c)
 661                                 call_list(PL_scopestack_ix, PL_endav);
 662                         JMPENV_POP;
 663                 }
 664                 LEAVE;
 665                 FREETMPS;
 666
 667                 *interp = NULL;
 668         }
 669 }
 670
 671
 672 static void
 673 plperl_trusted_init(void)
 674 {
 675         SV                 *safe_version_sv;
 676         IV                      safe_version_x100;
 677
 678         safe_version_sv = eval_pv(SAFE_MODULE, FALSE);/* TRUE = croak if failure */
 679         safe_version_x100 = (int)(SvNV(safe_version_sv) * 100);
 680
 681         /*
 682          * Reject too-old versions of Safe and some others:
 683          * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
 684          * 2.21: http://rt.perl.org/rt3/Ticket/Display.html?id=72700
 685          */
 686         if (safe_version_x100 < 209 || safe_version_x100 == 220 ||
 687                 safe_version_x100 == 221)
 688         {
 689                 /* not safe, so disallow all trusted funcs */
 690                 eval_pv(PLC_SAFE_BAD, FALSE);
 691                 if (SvTRUE(ERRSV))
 692                         ereport(ERROR,
 693                                         (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 694                                          errcontext("While executing PLC_SAFE_BAD.")));
 695         }
 696         else
 697         {
 698                 eval_pv(PLC_SAFE_OK, FALSE);
 699                 if (SvTRUE(ERRSV))
 700                         ereport(ERROR,
 701                                         (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 702                                          errcontext("While executing PLC_SAFE_OK.")));
 703
 704                 if (GetDatabaseEncoding() == PG_UTF8)
 705                 {
 706                         /*
 707                          * Force loading of utf8 module now to prevent errors that can
 708                          * arise from the regex code later trying to load utf8 modules.
 709                          * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
 710                          */
 711                         eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
 712                         if (SvTRUE(ERRSV))
 713                                 ereport(ERROR,
 714                                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 715                                                  errcontext("While executing utf8fix.")));
 716                 }
 717
 718                 /* switch to the safe require opcode */
 719                 PL_ppaddr[OP_REQUIRE] = pp_require_safe;
 720
 721                 if (plperl_on_plperl_init && *plperl_on_plperl_init)
 722                 {
 723                         dSP;
 724
 725                         PUSHMARK(SP);
 726                         XPUSHs(sv_2mortal(newSVstring(plperl_on_plperl_init)));
 727                         PUTBACK;
 728
 729                         call_pv("PostgreSQL::InServer::safe::safe_eval", G_VOID);
 730                         SPAGAIN;
 731
 732                         if (SvTRUE(ERRSV))
 733                                 ereport(ERROR,
 734                                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 735                                                  errcontext("While executing plperl.on_plperl_init.")));
 736                 }
 737
 738         }
 739 }
 740
 741
 742 static void
 743 plperl_untrusted_init(void)
 744 {
 745         if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
 746         {
 747                 eval_pv(plperl_on_plperlu_init, FALSE);
 748                 if (SvTRUE(ERRSV))
 749                         ereport(ERROR,
 750                                         (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
 751                                          errcontext("While executing plperl.on_plperlu_init.")));
 752         }
 753 }
 754
 755
 756 /*
 757  * Perl likes to put a newline after its error messages; clean up such
 758  */
 759 static char *
 760 strip_trailing_ws(const char *msg)
 761 {
 762         char       *res = pstrdup(msg);
 763         int                     len = strlen(res);
 764
 765         while (len > 0 && isspace((unsigned char) res[len - 1]))
 766                 res[--len] = '\0';
 767         return res;
 768 }
 769
 770
 771 /* Build a tuple from a hash. */
 772
 773 static HeapTuple
 774 plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
 775 {
 776         TupleDesc       td = attinmeta->tupdesc;
 777         char      **values;
 778         SV                 *val;
 779         char       *key;
 780         I32                     klen;
 781         HeapTuple       tup;
 782
 783         values = (char **) palloc0(td->natts * sizeof(char *));
 784
 785         hv_iterinit(perlhash);
 786         while ((val = hv_iternextsv(perlhash, &key, &klen)))
 787         {
 788                 int                     attn = SPI_fnumber(td, key);
 789
 790                 if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
 791                         ereport(ERROR,
 792                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 793                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 794                                                         key)));
 795                 if (SvOK(val))
 796                 {
 797                         values[attn - 1] = sv2text_mbverified(val);
 798                 }
 799         }
 800         hv_iterinit(perlhash);
 801
 802         tup = BuildTupleFromCStrings(attinmeta, values);
 803         pfree(values);
 804         return tup;
 805 }
 806
 807 /*
 808  * convert perl array to postgres string representation
 809  */
 810 static SV  *
 811 plperl_convert_to_pg_array(SV *src)
 812 {
 813         SV                 *rv;
 814         int                     count;
 815         dSP;
 816
 817         PUSHMARK(SP);
 818         XPUSHs(src);
 819         PUTBACK;
 820
 821         count = perl_call_pv("::encode_array_literal", G_SCALAR);
 822
 823         SPAGAIN;
 824
 825         if (count != 1)
 826                 elog(ERROR, "unexpected encode_array_literal failure");
 827
 828         rv = POPs;
 829
 830         PUTBACK;
 831
 832         return rv;
 833 }
 834
 835
 836 /* Set up the arguments for a trigger call. */
 837
 838 static SV  *
 839 plperl_trigger_build_args(FunctionCallInfo fcinfo)
 840 {
 841         TriggerData *tdata;
 842         TupleDesc       tupdesc;
 843         int                     i;
 844         char       *level;
 845         char       *event;
 846         char       *relid;
 847         char       *when;
 848         HV                 *hv;
 849
 850         hv = newHV();
 851         hv_ksplit(hv, 12); /* pre-grow the hash */
 852
 853         tdata = (TriggerData *) fcinfo->context;
 854         tupdesc = tdata->tg_relation->rd_att;
 855
 856         relid = DatumGetCString(
 857                                                         DirectFunctionCall1(oidout,
 858                                                                   ObjectIdGetDatum(tdata->tg_relation->rd_id)
 859                                                                                                 )
 860                 );
 861
 862         hv_store_string(hv, "name", newSVstring(tdata->tg_trigger->tgname));
 863         hv_store_string(hv, "relid", newSVstring(relid));
 864
 865         if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
 866         {
 867                 event = "INSERT";
 868                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 869                         hv_store_string(hv, "new",
 870                                                         plperl_hash_from_tuple(tdata->tg_trigtuple,
 871                                                                                                    tupdesc));
 872         }
 873         else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
 874         {
 875                 event = "DELETE";
 876                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 877                         hv_store_string(hv, "old",
 878                                                         plperl_hash_from_tuple(tdata->tg_trigtuple,
 879                                                                                                    tupdesc));
 880         }
 881         else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
 882         {
 883                 event = "UPDATE";
 884                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 885                 {
 886                         hv_store_string(hv, "old",
 887                                                         plperl_hash_from_tuple(tdata->tg_trigtuple,
 888                                                                                                    tupdesc));
 889                         hv_store_string(hv, "new",
 890                                                         plperl_hash_from_tuple(tdata->tg_newtuple,
 891                                                                                                    tupdesc));
 892                 }
 893         }
 894         else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
 895                 event = "TRUNCATE";
 896         else
 897                 event = "UNKNOWN";
 898
 899         hv_store_string(hv, "event", newSVstring(event));
 900         hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
 901
 902         if (tdata->tg_trigger->tgnargs > 0)
 903         {
 904                 AV                 *av = newAV();
 905
 906                 av_extend(av, tdata->tg_trigger->tgnargs);
 907                 for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
 908                         av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
 909                 hv_store_string(hv, "args", newRV_noinc((SV *) av));
 910         }
 911
 912         hv_store_string(hv, "relname",
 913                                         newSVstring(SPI_getrelname(tdata->tg_relation)));
 914
 915         hv_store_string(hv, "table_name",
 916                                         newSVstring(SPI_getrelname(tdata->tg_relation)));
 917
 918         hv_store_string(hv, "table_schema",
 919                                         newSVstring(SPI_getnspname(tdata->tg_relation)));
 920
 921         if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
 922                 when = "BEFORE";
 923         else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
 924                 when = "AFTER";
 925         else
 926                 when = "UNKNOWN";
 927         hv_store_string(hv, "when", newSVstring(when));
 928
 929         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 930                 level = "ROW";
 931         else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
 932                 level = "STATEMENT";
 933         else
 934                 level = "UNKNOWN";
 935         hv_store_string(hv, "level", newSVstring(level));
 936
 937         return newRV_noinc((SV *) hv);
 938 }
 939
 940
 941 /* Set up the new tuple returned from a trigger. */
 942
 943 static HeapTuple
 944 plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 945 {
 946         SV                **svp;
 947         HV                 *hvNew;
 948         HeapTuple       rtup;
 949         SV                 *val;
 950         char       *key;
 951         I32                     klen;
 952         int                     slotsused;
 953         int                *modattrs;
 954         Datum      *modvalues;
 955         char       *modnulls;
 956
 957         TupleDesc       tupdesc;
 958
 959         tupdesc = tdata->tg_relation->rd_att;
 960
 961         svp = hv_fetch_string(hvTD, "new");
 962         if (!svp)
 963                 ereport(ERROR,
 964                                 (errcode(ERRCODE_UNDEFINED_COLUMN),
 965                                  errmsg("$_TD->{new} does not exist")));
 966         if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
 967                 ereport(ERROR,
 968                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
 969                                  errmsg("$_TD->{new} is not a hash reference")));
 970         hvNew = (HV *) SvRV(*svp);
 971
 972         modattrs = palloc(tupdesc->natts * sizeof(int));
 973         modvalues = palloc(tupdesc->natts * sizeof(Datum));
 974         modnulls = palloc(tupdesc->natts * sizeof(char));
 975         slotsused = 0;
 976
 977         hv_iterinit(hvNew);
 978         while ((val = hv_iternextsv(hvNew, &key, &klen)))
 979         {
 980                 int                     attn = SPI_fnumber(tupdesc, key);
 981                 Oid                     typinput;
 982                 Oid                     typioparam;
 983                 int32           atttypmod;
 984                 FmgrInfo        finfo;
 985
 986                 if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
 987                         ereport(ERROR,
 988                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 989                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 990                                                         key)));
 991                 /* XXX would be better to cache these lookups */
 992                 getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid,
 993                                                  &typinput, &typioparam);
 994                 fmgr_info(typinput, &finfo);
 995                 atttypmod = tupdesc->attrs[attn - 1]->atttypmod;
 996                 if (SvOK(val))
 997                 {
 998                         modvalues[slotsused] = InputFunctionCall(&finfo,
 999                                                                                                          sv2text_mbverified(val),
1000                                                                                                          typioparam,
1001                                                                                                          atttypmod);
1002                         modnulls[slotsused] = ' ';
1003                 }
1004                 else
1005                 {
1006                         modvalues[slotsused] = InputFunctionCall(&finfo,
1007                                                                                                          NULL,
1008                                                                                                          typioparam,
1009                                                                                                          atttypmod);
1010                         modnulls[slotsused] = 'n';
1011                 }
1012                 modattrs[slotsused] = attn;
1013                 slotsused++;
1014         }
1015         hv_iterinit(hvNew);
1016
1017         rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
1018                                                    modattrs, modvalues, modnulls);
1019
1020         pfree(modattrs);
1021         pfree(modvalues);
1022         pfree(modnulls);
1023
1024         if (rtup == NULL)
1025                 elog(ERROR, "SPI_modifytuple failed: %s",
1026                          SPI_result_code_string(SPI_result));
1027
1028         return rtup;
1029 }
1030
1031
1032 /*
1033  * There are three externally visible pieces to plperl: plperl_call_handler,
1034  * plperl_inline_handler, and plperl_validator.
1035  */
1036
1037 /*
1038  * The call handler is called to run normal functions (including trigger
1039  * functions) that are defined in pg_proc.
1040  */
1041 PG_FUNCTION_INFO_V1(plperl_call_handler);
1042
1043 Datum
1044 plperl_call_handler(PG_FUNCTION_ARGS)
1045 {
1046         Datum           retval;
1047         plperl_call_data *save_call_data = current_call_data;
1048         bool            oldcontext = trusted_context;
1049
1050         PG_TRY();
1051         {
1052                 if (CALLED_AS_TRIGGER(fcinfo))
1053                         retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
1054                 else
1055                         retval = plperl_func_handler(fcinfo);
1056         }
1057         PG_CATCH();
1058         {
1059                 current_call_data = save_call_data;
1060                 restore_context(oldcontext);
1061                 PG_RE_THROW();
1062         }
1063         PG_END_TRY();
1064
1065         current_call_data = save_call_data;
1066         restore_context(oldcontext);
1067         return retval;
1068 }
1069
1070 /*
1071  * The inline handler runs anonymous code blocks (DO blocks).
1072  */
1073 PG_FUNCTION_INFO_V1(plperl_inline_handler);
1074
1075 Datum
1076 plperl_inline_handler(PG_FUNCTION_ARGS)
1077 {
1078         InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
1079         FunctionCallInfoData fake_fcinfo;
1080         FmgrInfo flinfo;
1081         plperl_proc_desc desc;
1082         plperl_call_data *save_call_data = current_call_data;
1083         bool            oldcontext = trusted_context;
1084         ErrorContextCallback pl_error_context;
1085
1086         /* Set up a callback for error reporting */
1087         pl_error_context.callback = plperl_inline_callback;
1088         pl_error_context.previous = error_context_stack;
1089         pl_error_context.arg = (Datum) 0;
1090         error_context_stack = &pl_error_context;
1091
1092         /*
1093          * Set up a fake fcinfo and descriptor with just enough info to satisfy
1094          * plperl_call_perl_func().  In particular note that this sets things up
1095          * with no arguments passed, and a result type of VOID.
1096          */
1097         MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo));
1098         MemSet(&flinfo, 0, sizeof(flinfo));
1099         MemSet(&desc, 0, sizeof(desc));
1100         fake_fcinfo.flinfo = &flinfo;
1101         flinfo.fn_oid = InvalidOid;
1102         flinfo.fn_mcxt = CurrentMemoryContext;
1103
1104         desc.proname = "inline_code_block";
1105         desc.fn_readonly = false;
1106
1107         desc.lanpltrusted = codeblock->langIsTrusted;
1108
1109         desc.fn_retistuple = false;
1110         desc.fn_retisset = false;
1111         desc.fn_retisarray = false;
1112         desc.result_oid = VOIDOID;
1113         desc.nargs = 0;
1114         desc.reference = NULL;
1115
1116         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1117         current_call_data->fcinfo = &fake_fcinfo;
1118         current_call_data->prodesc = &desc;
1119
1120         PG_TRY();
1121         {
1122                 SV                 *perlret;
1123
1124                 if (SPI_connect() != SPI_OK_CONNECT)
1125                         elog(ERROR, "could not connect to SPI manager");
1126
1127                 select_perl_context(desc.lanpltrusted);
1128
1129                 plperl_create_sub(&desc, codeblock->source_text, 0);
1130
1131                 if (!desc.reference)    /* can this happen? */
1132                         elog(ERROR, "could not create internal procedure for anonymous code block");
1133
1134                 perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
1135
1136                 SvREFCNT_dec(perlret);
1137
1138                 if (SPI_finish() != SPI_OK_FINISH)
1139                         elog(ERROR, "SPI_finish() failed");
1140         }
1141         PG_CATCH();
1142         {
1143                 current_call_data = save_call_data;
1144                 restore_context(oldcontext);
1145                 if (desc.reference)
1146                         SvREFCNT_dec(desc.reference);
1147                 PG_RE_THROW();
1148         }
1149         PG_END_TRY();
1150
1151         current_call_data = save_call_data;
1152         restore_context(oldcontext);
1153         if (desc.reference)
1154                 SvREFCNT_dec(desc.reference);
1155
1156         error_context_stack = pl_error_context.previous;
1157
1158         PG_RETURN_VOID();
1159 }
1160
1161 /*
1162  * The validator is called during CREATE FUNCTION to validate the function
1163  * being created/replaced. The precise behavior of the validator may be
1164  * modified by the check_function_bodies GUC.
1165  */
1166 PG_FUNCTION_INFO_V1(plperl_validator);
1167
1168 Datum
1169 plperl_validator(PG_FUNCTION_ARGS)
1170 {
1171         Oid                     funcoid = PG_GETARG_OID(0);
1172         HeapTuple       tuple;
1173         Form_pg_proc proc;
1174         char            functyptype;
1175         int                     numargs;
1176         Oid                *argtypes;
1177         char      **argnames;
1178         char       *argmodes;
1179         bool            istrigger = false;
1180         int                     i;
1181
1182         /* Get the new function's pg_proc entry */
1183         tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
1184         if (!HeapTupleIsValid(tuple))
1185                 elog(ERROR, "cache lookup failed for function %u", funcoid);
1186         proc = (Form_pg_proc) GETSTRUCT(tuple);
1187
1188         functyptype = get_typtype(proc->prorettype);
1189
1190         /* Disallow pseudotype result */
1191         /* except for TRIGGER, RECORD, or VOID */
1192         if (functyptype == TYPTYPE_PSEUDO)
1193         {
1194                 /* we assume OPAQUE with no arguments means a trigger */
1195                 if (proc->prorettype == TRIGGEROID ||
1196                         (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
1197                         istrigger = true;
1198                 else if (proc->prorettype != RECORDOID &&
1199                                  proc->prorettype != VOIDOID)
1200                         ereport(ERROR,
1201                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1202                                          errmsg("PL/Perl functions cannot return type %s",
1203                                                         format_type_be(proc->prorettype))));
1204         }
1205
1206         /* Disallow pseudotypes in arguments (either IN or OUT) */
1207         numargs = get_func_arg_info(tuple,
1208                                                                 &argtypes, &argnames, &argmodes);
1209         for (i = 0; i < numargs; i++)
1210         {
1211                 if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO)
1212                         ereport(ERROR,
1213                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1214                                          errmsg("PL/Perl functions cannot accept type %s",
1215                                                         format_type_be(argtypes[i]))));
1216         }
1217
1218         ReleaseSysCache(tuple);
1219
1220         /* Postpone body checks if !check_function_bodies */
1221         if (check_function_bodies)
1222         {
1223                 (void) compile_plperl_function(funcoid, istrigger);
1224         }
1225
1226         /* the result of a validator is ignored */
1227         PG_RETURN_VOID();
1228 }
1229
1230
1231 /*
1232  * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
1233  * supplied in s, and returns a reference to it
1234  */
1235 static void
1236 plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
1237 {
1238         dSP;
1239         bool        trusted = prodesc->lanpltrusted;
1240         char        subname[NAMEDATALEN+40];
1241         HV         *pragma_hv = newHV();
1242         SV         *subref = NULL;
1243         int         count;
1244         char       *compile_sub;
1245
1246         sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
1247
1248         if (plperl_use_strict)
1249                 hv_store_string(pragma_hv, "strict", (SV*)newAV());
1250
1251         ENTER;
1252         SAVETMPS;
1253         PUSHMARK(SP);
1254         EXTEND(SP,4);
1255         PUSHs(sv_2mortal(newSVstring(subname)));
1256         PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
1257         PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;")));
1258         PUSHs(sv_2mortal(newSVstring(s)));
1259         PUTBACK;
1260
1261         /*
1262          * G_KEEPERR seems to be needed here, else we don't recognize compile
1263          * errors properly.  Perhaps it's because there's another level of eval
1264          * inside mksafefunc?
1265          */
1266         compile_sub = (trusted)
1267                 ? "PostgreSQL::InServer::safe::mksafefunc"
1268                 : "PostgreSQL::InServer::mkunsafefunc";
1269         count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
1270         SPAGAIN;
1271
1272         if (count == 1) {
1273                 GV *sub_glob = (GV*)POPs;
1274                 if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV) {
1275                         SV *sv = (SV*)GvCVu((GV*)sub_glob);
1276                         if (sv)
1277                                 subref = newRV_inc(sv);
1278                 }
1279         }
1280
1281         PUTBACK;
1282         FREETMPS;
1283         LEAVE;
1284
1285         if (SvTRUE(ERRSV))
1286                 ereport(ERROR,
1287                                 (errcode(ERRCODE_SYNTAX_ERROR),
1288                                  errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
1289
1290         if (!subref)
1291                 ereport(ERROR,
1292                                 (errmsg("didn't get a GLOB from compiling %s via %s",
1293                                                 prodesc->proname, compile_sub)));
1294
1295         prodesc->reference = newSVsv(subref);
1296
1297         return;
1298 }
1299
1300
1301 /**********************************************************************
1302  * plperl_init_shared_libs()            -
1303  *
1304  * We cannot use the DynaLoader directly to get at the Opcode
1305  * module (used by Safe.pm). So, we link Opcode into ourselves
1306  * and do the initialization behind perl's back.
1307  *
1308  **********************************************************************/
1309
1310 static void
1311 plperl_init_shared_libs(pTHX)
1312 {
1313         char       *file = __FILE__;
1314         EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
1315         EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
1316
1317         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
1318         newXS("PostgreSQL::InServer::Util::bootstrap",
1319                 boot_PostgreSQL__InServer__Util, file);
1320         /* newXS for...::SPI::bootstrap is in select_perl_context() */
1321 }
1322
1323
1324 static SV  *
1325 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
1326 {
1327         dSP;
1328         SV                 *retval;
1329         int                     i;
1330         int                     count;
1331         SV                 *sv;
1332
1333         ENTER;
1334         SAVETMPS;
1335
1336         PUSHMARK(SP);
1337         EXTEND(sp, 1 + desc->nargs);
1338
1339         PUSHs(&PL_sv_undef);            /* no trigger data */
1340
1341         for (i = 0; i < desc->nargs; i++)
1342         {
1343                 if (fcinfo->argnull[i])
1344                         PUSHs(&PL_sv_undef);
1345                 else if (desc->arg_is_rowtype[i])
1346                 {
1347                         HeapTupleHeader td;
1348                         Oid                     tupType;
1349                         int32           tupTypmod;
1350                         TupleDesc       tupdesc;
1351                         HeapTupleData tmptup;
1352                         SV                 *hashref;
1353
1354                         td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
1355                         /* Extract rowtype info and find a tupdesc */
1356                         tupType = HeapTupleHeaderGetTypeId(td);
1357                         tupTypmod = HeapTupleHeaderGetTypMod(td);
1358                         tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
1359                         /* Build a temporary HeapTuple control structure */
1360                         tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
1361                         tmptup.t_data = td;
1362
1363                         hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
1364                         PUSHs(sv_2mortal(hashref));
1365                         ReleaseTupleDesc(tupdesc);
1366                 }
1367                 else
1368                 {
1369                         char       *tmp;
1370
1371                         tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
1372                                                                          fcinfo->arg[i]);
1373                         sv = newSVstring(tmp);
1374                         PUSHs(sv_2mortal(sv));
1375                         pfree(tmp);
1376                 }
1377         }
1378         PUTBACK;
1379
1380         /* Do NOT use G_KEEPERR here */
1381         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
1382
1383         SPAGAIN;
1384
1385         if (count != 1)
1386         {
1387                 PUTBACK;
1388                 FREETMPS;
1389                 LEAVE;
1390                 elog(ERROR, "didn't get a return item from function");
1391         }
1392
1393         if (SvTRUE(ERRSV))
1394         {
1395                 (void) POPs;
1396                 PUTBACK;
1397                 FREETMPS;
1398                 LEAVE;
1399                 /* XXX need to find a way to assign an errcode here */
1400                 ereport(ERROR,
1401                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
1402         }
1403
1404         retval = newSVsv(POPs);
1405
1406         PUTBACK;
1407         FREETMPS;
1408         LEAVE;
1409
1410         return retval;
1411 }
1412
1413
1414 static SV  *
1415 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
1416                                                           SV *td)
1417 {
1418         dSP;
1419         SV                 *retval;
1420         Trigger    *tg_trigger;
1421         int                     i;
1422         int                     count;
1423
1424         ENTER;
1425         SAVETMPS;
1426
1427         PUSHMARK(sp);
1428
1429         XPUSHs(td);
1430
1431         tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
1432         for (i = 0; i < tg_trigger->tgnargs; i++)
1433                 XPUSHs(sv_2mortal(newSVstring(tg_trigger->tgargs[i])));
1434         PUTBACK;
1435
1436         /* Do NOT use G_KEEPERR here */
1437         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
1438
1439         SPAGAIN;
1440
1441         if (count != 1)
1442         {
1443                 PUTBACK;
1444                 FREETMPS;
1445                 LEAVE;
1446                 elog(ERROR, "didn't get a return item from trigger function");
1447         }
1448
1449         if (SvTRUE(ERRSV))
1450         {
1451                 (void) POPs;
1452                 PUTBACK;
1453                 FREETMPS;
1454                 LEAVE;
1455                 /* XXX need to find a way to assign an errcode here */
1456                 ereport(ERROR,
1457                                 (errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
1458         }
1459
1460         retval = newSVsv(POPs);
1461
1462         PUTBACK;
1463         FREETMPS;
1464         LEAVE;
1465
1466         return retval;
1467 }
1468
1469
1470 static Datum
1471 plperl_func_handler(PG_FUNCTION_ARGS)
1472 {
1473         plperl_proc_desc *prodesc;
1474         SV                 *perlret;
1475         Datum           retval;
1476         ReturnSetInfo *rsi;
1477         SV                 *array_ret = NULL;
1478         ErrorContextCallback pl_error_context;
1479
1480         /*
1481          * Create the call_data beforing connecting to SPI, so that it is not
1482          * allocated in the SPI memory context
1483          */
1484         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1485         current_call_data->fcinfo = fcinfo;
1486
1487         if (SPI_connect() != SPI_OK_CONNECT)
1488                 elog(ERROR, "could not connect to SPI manager");
1489
1490         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
1491         current_call_data->prodesc = prodesc;
1492
1493         /* Set a callback for error reporting */
1494         pl_error_context.callback = plperl_exec_callback;
1495         pl_error_context.previous = error_context_stack;
1496         pl_error_context.arg = prodesc->proname;
1497         error_context_stack = &pl_error_context;
1498
1499         rsi = (ReturnSetInfo *) fcinfo->resultinfo;
1500
1501         if (prodesc->fn_retisset)
1502         {
1503                 /* Check context before allowing the call to go through */
1504                 if (!rsi || !IsA(rsi, ReturnSetInfo) ||
1505                         (rsi->allowedModes & SFRM_Materialize) == 0 ||
1506                         rsi->expectedDesc == NULL)
1507                         ereport(ERROR,
1508                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1509                                          errmsg("set-valued function called in context that "
1510                                                         "cannot accept a set")));
1511         }
1512
1513         select_perl_context(prodesc->lanpltrusted);
1514
1515         perlret = plperl_call_perl_func(prodesc, fcinfo);
1516
1517         /************************************************************
1518          * Disconnect from SPI manager and then create the return
1519          * values datum (if the input function does a palloc for it
1520          * this must not be allocated in the SPI memory context
1521          * because SPI_finish would free it).
1522          ************************************************************/
1523         if (SPI_finish() != SPI_OK_FINISH)
1524                 elog(ERROR, "SPI_finish() failed");
1525
1526         if (prodesc->fn_retisset)
1527         {
1528                 /*
1529                  * If the Perl function returned an arrayref, we pretend that it
1530                  * called return_next() for each element of the array, to handle old
1531                  * SRFs that didn't know about return_next(). Any other sort of return
1532                  * value is an error, except undef which means return an empty set.
1533                  */
1534                 if (SvOK(perlret) &&
1535                         SvTYPE(perlret) == SVt_RV &&
1536                         SvTYPE(SvRV(perlret)) == SVt_PVAV)
1537                 {
1538                         int                     i = 0;
1539                         SV                **svp = 0;
1540                         AV                 *rav = (AV *) SvRV(perlret);
1541
1542                         while ((svp = av_fetch(rav, i, FALSE)) != NULL)
1543                         {
1544                                 plperl_return_next(*svp);
1545                                 i++;
1546                         }
1547                 }
1548                 else if (SvOK(perlret))
1549                 {
1550                         ereport(ERROR,
1551                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
1552                                          errmsg("set-returning PL/Perl function must return "
1553                                                         "reference to array or use return_next")));
1554                 }
1555
1556                 rsi->returnMode = SFRM_Materialize;
1557                 if (current_call_data->tuple_store)
1558                 {
1559                         rsi->setResult = current_call_data->tuple_store;
1560                         rsi->setDesc = current_call_data->ret_tdesc;
1561                 }
1562                 retval = (Datum) 0;
1563         }
1564         else if (!SvOK(perlret))
1565         {
1566                 /* Return NULL if Perl code returned undef */
1567                 if (rsi && IsA(rsi, ReturnSetInfo))
1568                         rsi->isDone = ExprEndResult;
1569                 retval = InputFunctionCall(&prodesc->result_in_func, NULL,
1570                                                                    prodesc->result_typioparam, -1);
1571                 fcinfo->isnull = true;
1572         }
1573         else if (prodesc->fn_retistuple)
1574         {
1575                 /* Return a perl hash converted to a Datum */
1576                 TupleDesc       td;
1577                 AttInMetadata *attinmeta;
1578                 HeapTuple       tup;
1579
1580                 if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
1581                         SvTYPE(SvRV(perlret)) != SVt_PVHV)
1582                 {
1583                         ereport(ERROR,
1584                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
1585                                          errmsg("composite-returning PL/Perl function "
1586                                                         "must return reference to hash")));
1587                 }
1588
1589                 /* XXX should cache the attinmeta data instead of recomputing */
1590                 if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
1591                 {
1592                         ereport(ERROR,
1593                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1594                                          errmsg("function returning record called in context "
1595                                                         "that cannot accept type record")));
1596                 }
1597
1598                 attinmeta = TupleDescGetAttInMetadata(td);
1599                 tup = plperl_build_tuple_result((HV *) SvRV(perlret), attinmeta);
1600                 retval = HeapTupleGetDatum(tup);
1601         }
1602         else
1603         {
1604                 /* Return a perl string converted to a Datum */
1605
1606                 if (prodesc->fn_retisarray && SvROK(perlret) &&
1607                         SvTYPE(SvRV(perlret)) == SVt_PVAV)
1608                 {
1609                         array_ret = plperl_convert_to_pg_array(perlret);
1610                         SvREFCNT_dec(perlret);
1611                         perlret = array_ret;
1612                 }
1613
1614                 retval = InputFunctionCall(&prodesc->result_in_func,
1615                                                                    sv2text_mbverified(perlret),
1616                                                                    prodesc->result_typioparam, -1);
1617         }
1618
1619         /* Restore the previous error callback */
1620         error_context_stack = pl_error_context.previous;
1621
1622         if (array_ret == NULL)
1623                 SvREFCNT_dec(perlret);
1624
1625         return retval;
1626 }
1627
1628
1629 static Datum
1630 plperl_trigger_handler(PG_FUNCTION_ARGS)
1631 {
1632         plperl_proc_desc *prodesc;
1633         SV                 *perlret;
1634         Datum           retval;
1635         SV                 *svTD;
1636         HV                 *hvTD;
1637         ErrorContextCallback pl_error_context;
1638
1639         /*
1640          * Create the call_data beforing connecting to SPI, so that it is not
1641          * allocated in the SPI memory context
1642          */
1643         current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
1644         current_call_data->fcinfo = fcinfo;
1645
1646         /* Connect to SPI manager */
1647         if (SPI_connect() != SPI_OK_CONNECT)
1648                 elog(ERROR, "could not connect to SPI manager");
1649
1650         /* Find or compile the function */
1651         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
1652         current_call_data->prodesc = prodesc;
1653
1654         /* Set a callback for error reporting */
1655         pl_error_context.callback = plperl_exec_callback;
1656         pl_error_context.previous = error_context_stack;
1657         pl_error_context.arg = prodesc->proname;
1658         error_context_stack = &pl_error_context;
1659
1660         select_perl_context(prodesc->lanpltrusted);
1661
1662         svTD = plperl_trigger_build_args(fcinfo);
1663         perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
1664         hvTD = (HV *) SvRV(svTD);
1665
1666         /************************************************************
1667         * Disconnect from SPI manager and then create the return
1668         * values datum (if the input function does a palloc for it
1669         * this must not be allocated in the SPI memory context
1670         * because SPI_finish would free it).
1671         ************************************************************/
1672         if (SPI_finish() != SPI_OK_FINISH)
1673                 elog(ERROR, "SPI_finish() failed");
1674
1675         if (perlret == NULL || !SvOK(perlret))
1676         {
1677                 /* undef result means go ahead with original tuple */
1678                 TriggerData *trigdata = ((TriggerData *) fcinfo->context);
1679
1680                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1681                         retval = (Datum) trigdata->tg_trigtuple;
1682                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1683                         retval = (Datum) trigdata->tg_newtuple;
1684                 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
1685                         retval = (Datum) trigdata->tg_trigtuple;
1686                 else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
1687                         retval = (Datum) trigdata->tg_trigtuple;
1688                 else
1689                         retval = (Datum) 0; /* can this happen? */
1690         }
1691         else
1692         {
1693                 HeapTuple       trv;
1694                 char       *tmp;
1695
1696                 tmp = SvPV_nolen(perlret);
1697
1698                 if (pg_strcasecmp(tmp, "SKIP") == 0)
1699                         trv = NULL;
1700                 else if (pg_strcasecmp(tmp, "MODIFY") == 0)
1701                 {
1702                         TriggerData *trigdata = (TriggerData *) fcinfo->context;
1703
1704                         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1705                                 trv = plperl_modify_tuple(hvTD, trigdata,
1706                                                                                   trigdata->tg_trigtuple);
1707                         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1708                                 trv = plperl_modify_tuple(hvTD, trigdata,
1709                                                                                   trigdata->tg_newtuple);
1710                         else
1711                         {
1712                                 ereport(WARNING,
1713                                                 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1714                                                  errmsg("ignoring modified row in DELETE trigger")));
1715                                 trv = NULL;
1716                         }
1717                 }
1718                 else
1719                 {
1720                         ereport(ERROR,
1721                                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1722                                   errmsg("result of PL/Perl trigger function must be undef, "
1723                                                  "\"SKIP\", or \"MODIFY\"")));
1724                         trv = NULL;
1725                 }
1726                 retval = PointerGetDatum(trv);
1727         }
1728
1729         /* Restore the previous error callback */
1730         error_context_stack = pl_error_context.previous;
1731
1732         SvREFCNT_dec(svTD);
1733         if (perlret)
1734                 SvREFCNT_dec(perlret);
1735
1736         return retval;
1737 }
1738
1739
1740 static plperl_proc_desc *
1741 compile_plperl_function(Oid fn_oid, bool is_trigger)
1742 {
1743         HeapTuple       procTup;
1744         Form_pg_proc procStruct;
1745         char            internal_proname[NAMEDATALEN];
1746         plperl_proc_desc *prodesc = NULL;
1747         int                     i;
1748         plperl_proc_entry *hash_entry;
1749         bool            found;
1750         bool            oldcontext = trusted_context;
1751         ErrorContextCallback plperl_error_context;
1752
1753         /* We'll need the pg_proc tuple in any case... */
1754         procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
1755         if (!HeapTupleIsValid(procTup))
1756                 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1757         procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1758
1759         /* Set a callback for reporting compilation errors */
1760         plperl_error_context.callback = plperl_compile_callback;
1761         plperl_error_context.previous = error_context_stack;
1762         plperl_error_context.arg = NameStr(procStruct->proname);
1763         error_context_stack = &plperl_error_context;
1764
1765         /************************************************************
1766          * Build our internal proc name from the function's Oid
1767          ************************************************************/
1768         if (!is_trigger)
1769                 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
1770         else
1771                 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
1772
1773         /************************************************************
1774          * Lookup the internal proc name in the hashtable
1775          ************************************************************/
1776         hash_entry = hash_search(plperl_proc_hash, internal_proname,
1777                                                          HASH_FIND, NULL);
1778
1779         if (hash_entry)
1780         {
1781                 bool            uptodate;
1782
1783                 prodesc = hash_entry->proc_data;
1784
1785                 /************************************************************
1786                  * If it's present, must check whether it's still up to date.
1787                  * This is needed because CREATE OR REPLACE FUNCTION can modify the
1788                  * function's pg_proc entry without changing its OID.
1789                  ************************************************************/
1790                 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
1791                                         ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
1792
1793                 if (!uptodate)
1794                 {
1795                         hash_search(plperl_proc_hash, internal_proname,
1796                                                 HASH_REMOVE, NULL);
1797                         if (prodesc->reference) {
1798                                 select_perl_context(prodesc->lanpltrusted);
1799                                 SvREFCNT_dec(prodesc->reference);
1800                                 restore_context(oldcontext);
1801                         }
1802                         free(prodesc->proname);
1803                         free(prodesc);
1804                         prodesc = NULL;
1805                 }
1806         }
1807
1808         /************************************************************
1809          * If we haven't found it in the hashtable, we analyze
1810          * the function's arguments and return type and store
1811          * the in-/out-functions in the prodesc block and create
1812          * a new hashtable entry for it.
1813          *
1814          * Then we load the procedure into the Perl interpreter.
1815          ************************************************************/
1816         if (prodesc == NULL)
1817         {
1818                 HeapTuple       langTup;
1819                 HeapTuple       typeTup;
1820                 Form_pg_language langStruct;
1821                 Form_pg_type typeStruct;
1822                 Datum           prosrcdatum;
1823                 bool            isnull;
1824                 char       *proc_source;
1825
1826                 /************************************************************
1827                  * Allocate a new procedure description block
1828                  ************************************************************/
1829                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
1830                 if (prodesc == NULL)
1831                         ereport(ERROR,
1832                                         (errcode(ERRCODE_OUT_OF_MEMORY),
1833                                          errmsg("out of memory")));
1834                 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
1835                 prodesc->proname = strdup(NameStr(procStruct->proname));
1836                 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
1837                 prodesc->fn_tid = procTup->t_self;
1838
1839                 /* Remember if function is STABLE/IMMUTABLE */
1840                 prodesc->fn_readonly =
1841                         (procStruct->provolatile != PROVOLATILE_VOLATILE);
1842
1843                 /************************************************************
1844                  * Lookup the pg_language tuple by Oid
1845                  ************************************************************/
1846                 langTup = SearchSysCache1(LANGOID,
1847                                                                   ObjectIdGetDatum(procStruct->prolang));
1848                 if (!HeapTupleIsValid(langTup))
1849                 {
1850                         free(prodesc->proname);
1851                         free(prodesc);
1852                         elog(ERROR, "cache lookup failed for language %u",
1853                                  procStruct->prolang);
1854                 }
1855                 langStruct = (Form_pg_language) GETSTRUCT(langTup);
1856                 prodesc->lanpltrusted = langStruct->lanpltrusted;
1857                 ReleaseSysCache(langTup);
1858
1859                 /************************************************************
1860                  * Get the required information for input conversion of the
1861                  * return value.
1862                  ************************************************************/
1863                 if (!is_trigger)
1864                 {
1865                         typeTup =
1866                                 SearchSysCache1(TYPEOID,
1867                                                             ObjectIdGetDatum(procStruct->prorettype));
1868                         if (!HeapTupleIsValid(typeTup))
1869                         {
1870                                 free(prodesc->proname);
1871                                 free(prodesc);
1872                                 elog(ERROR, "cache lookup failed for type %u",
1873                                          procStruct->prorettype);
1874                         }
1875                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1876
1877                         /* Disallow pseudotype result, except VOID or RECORD */
1878                         if (typeStruct->typtype == TYPTYPE_PSEUDO)
1879                         {
1880                                 if (procStruct->prorettype == VOIDOID ||
1881                                         procStruct->prorettype == RECORDOID)
1882                                          /* okay */ ;
1883                                 else if (procStruct->prorettype == TRIGGEROID)
1884                                 {
1885                                         free(prodesc->proname);
1886                                         free(prodesc);
1887                                         ereport(ERROR,
1888                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1889                                                          errmsg("trigger functions can only be called "
1890                                                                         "as triggers")));
1891                                 }
1892                                 else
1893                                 {
1894                                         free(prodesc->proname);
1895                                         free(prodesc);
1896                                         ereport(ERROR,
1897                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1898                                                          errmsg("PL/Perl functions cannot return type %s",
1899                                                                         format_type_be(procStruct->prorettype))));
1900                                 }
1901                         }
1902
1903                         prodesc->result_oid = procStruct->prorettype;
1904                         prodesc->fn_retisset = procStruct->proretset;
1905                         prodesc->fn_retistuple = (procStruct->prorettype == RECORDOID ||
1906                                                                    typeStruct->typtype == TYPTYPE_COMPOSITE);
1907
1908                         prodesc->fn_retisarray =
1909                                 (typeStruct->typlen == -1 && typeStruct->typelem);
1910
1911                         perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1912                         prodesc->result_typioparam = getTypeIOParam(typeTup);
1913
1914                         ReleaseSysCache(typeTup);
1915                 }
1916
1917                 /************************************************************
1918                  * Get the required information for output conversion
1919                  * of all procedure arguments
1920                  ************************************************************/
1921                 if (!is_trigger)
1922                 {
1923                         prodesc->nargs = procStruct->pronargs;
1924                         for (i = 0; i < prodesc->nargs; i++)
1925                         {
1926                                 typeTup = SearchSysCache1(TYPEOID,
1927                                                  ObjectIdGetDatum(procStruct->proargtypes.values[i]));
1928                                 if (!HeapTupleIsValid(typeTup))
1929                                 {
1930                                         free(prodesc->proname);
1931                                         free(prodesc);
1932                                         elog(ERROR, "cache lookup failed for type %u",
1933                                                  procStruct->proargtypes.values[i]);
1934                                 }
1935                                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1936
1937                                 /* Disallow pseudotype argument */
1938                                 if (typeStruct->typtype == TYPTYPE_PSEUDO)
1939                                 {
1940                                         free(prodesc->proname);
1941                                         free(prodesc);
1942                                         ereport(ERROR,
1943                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1944                                                          errmsg("PL/Perl functions cannot accept type %s",
1945                                                 format_type_be(procStruct->proargtypes.values[i]))));
1946                                 }
1947
1948                                 if (typeStruct->typtype == TYPTYPE_COMPOSITE)
1949                                         prodesc->arg_is_rowtype[i] = true;
1950                                 else
1951                                 {
1952                                         prodesc->arg_is_rowtype[i] = false;
1953                                         perm_fmgr_info(typeStruct->typoutput,
1954                                                                    &(prodesc->arg_out_func[i]));
1955                                 }
1956
1957                                 ReleaseSysCache(typeTup);
1958                         }
1959                 }
1960
1961                 /************************************************************
1962                  * create the text of the anonymous subroutine.
1963                  * we do not use a named subroutine so that we can call directly
1964                  * through the reference.
1965                  ************************************************************/
1966                 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1967                                                                           Anum_pg_proc_prosrc, &isnull);
1968                 if (isnull)
1969                         elog(ERROR, "null prosrc");
1970                 proc_source = TextDatumGetCString(prosrcdatum);
1971
1972                 /************************************************************
1973                  * Create the procedure in the interpreter
1974                  ************************************************************/
1975
1976                 select_perl_context(prodesc->lanpltrusted);
1977
1978                 plperl_create_sub(prodesc, proc_source, fn_oid);
1979
1980                 restore_context(oldcontext);
1981
1982                 pfree(proc_source);
1983                 if (!prodesc->reference)        /* can this happen? */
1984                 {
1985                         free(prodesc->proname);
1986                         free(prodesc);
1987                         elog(ERROR, "could not create internal procedure \"%s\"",
1988                                  internal_proname);
1989                 }
1990
1991                 hash_entry = hash_search(plperl_proc_hash, internal_proname,
1992                                                                  HASH_ENTER, &found);
1993                 hash_entry->proc_data = prodesc;
1994         }
1995
1996         /* restore previous error callback */
1997         error_context_stack = plperl_error_context.previous;
1998
1999         ReleaseSysCache(procTup);
2000
2001         return prodesc;
2002 }
2003
2004
2005 /* Build a hash from all attributes of a given tuple. */
2006
2007 static SV  *
2008 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
2009 {
2010         HV                 *hv;
2011         int                     i;
2012
2013         hv = newHV();
2014         hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
2015
2016         for (i = 0; i < tupdesc->natts; i++)
2017         {
2018                 Datum           attr;
2019                 bool            isnull;
2020                 char       *attname;
2021                 char       *outputstr;
2022                 Oid                     typoutput;
2023                 bool            typisvarlena;
2024
2025                 if (tupdesc->attrs[i]->attisdropped)
2026                         continue;
2027
2028                 attname = NameStr(tupdesc->attrs[i]->attname);
2029                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
2030
2031                 if (isnull)
2032                 {
2033                         /* Store (attname => undef) and move on. */
2034                         hv_store_string(hv, attname, newSV(0));
2035                         continue;
2036                 }
2037
2038                 /* XXX should have a way to cache these lookups */
2039                 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
2040                                                   &typoutput, &typisvarlena);
2041
2042                 outputstr = OidOutputFunctionCall(typoutput, attr);
2043
2044                 hv_store_string(hv, attname, newSVstring(outputstr));
2045
2046                 pfree(outputstr);
2047         }
2048
2049         return newRV_noinc((SV *) hv);
2050 }
2051
2052
2053 static void
2054 check_spi_usage_allowed()
2055 {
2056         /* see comment in plperl_fini() */
2057         if (plperl_ending) {
2058                 /* simple croak as we don't want to involve PostgreSQL code */
2059                 croak("SPI functions can not be used in END blocks");
2060         }
2061 }
2062
2063
2064 HV *
2065 plperl_spi_exec(char *query, int limit)
2066 {
2067         HV                 *ret_hv;
2068
2069         /*
2070          * Execute the query inside a sub-transaction, so we can cope with errors
2071          * sanely
2072          */
2073         MemoryContext oldcontext = CurrentMemoryContext;
2074         ResourceOwner oldowner = CurrentResourceOwner;
2075
2076         check_spi_usage_allowed();
2077
2078         BeginInternalSubTransaction(NULL);
2079         /* Want to run inside function's memory context */
2080         MemoryContextSwitchTo(oldcontext);
2081
2082         PG_TRY();
2083         {
2084                 int                     spi_rv;
2085
2086                 spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
2087                                                          limit);
2088                 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
2089                                                                                                  spi_rv);
2090
2091                 /* Commit the inner transaction, return to outer xact context */
2092                 ReleaseCurrentSubTransaction();
2093                 MemoryContextSwitchTo(oldcontext);
2094                 CurrentResourceOwner = oldowner;
2095
2096                 /*
2097                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2098                  * in case it did, make sure we remain connected.
2099                  */
2100                 SPI_restore_connection();
2101         }
2102         PG_CATCH();
2103         {
2104                 ErrorData  *edata;
2105
2106                 /* Save error info */
2107                 MemoryContextSwitchTo(oldcontext);
2108                 edata = CopyErrorData();
2109                 FlushErrorState();
2110
2111                 /* Abort the inner transaction */
2112                 RollbackAndReleaseCurrentSubTransaction();
2113                 MemoryContextSwitchTo(oldcontext);
2114                 CurrentResourceOwner = oldowner;
2115
2116                 /*
2117                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2118                  * have left us in a disconnected state.  We need this hack to return
2119                  * to connected state.
2120                  */
2121                 SPI_restore_connection();
2122
2123                 /* Punt the error to Perl */
2124                 croak("%s", edata->message);
2125
2126                 /* Can't get here, but keep compiler quiet */
2127                 return NULL;
2128         }
2129         PG_END_TRY();
2130
2131         return ret_hv;
2132 }
2133
2134
2135 static HV  *
2136 plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
2137                                                                 int status)
2138 {
2139         HV                 *result;
2140
2141         check_spi_usage_allowed();
2142
2143         result = newHV();
2144
2145         hv_store_string(result, "status",
2146                                         newSVstring(SPI_result_code_string(status)));
2147         hv_store_string(result, "processed",
2148                                         newSViv(processed));
2149
2150         if (status > 0 && tuptable)
2151         {
2152                 AV                 *rows;
2153                 SV                 *row;
2154                 int                     i;
2155
2156                 rows = newAV();
2157                 av_extend(rows, processed);
2158                 for (i = 0; i < processed; i++)
2159                 {
2160                         row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
2161                         av_push(rows, row);
2162                 }
2163                 hv_store_string(result, "rows",
2164                                                 newRV_noinc((SV *) rows));
2165         }
2166
2167         SPI_freetuptable(tuptable);
2168
2169         return result;
2170 }
2171
2172
2173 /*
2174  * Note: plperl_return_next is called both in Postgres and Perl contexts.
2175  * We report any errors in Postgres fashion (via ereport).      If called in
2176  * Perl context, it is SPI.xs's responsibility to catch the error and
2177  * convert to a Perl error.  We assume (perhaps without adequate justification)
2178  * that we need not abort the current transaction if the Perl code traps the
2179  * error.
2180  */
2181 void
2182 plperl_return_next(SV *sv)
2183 {
2184         plperl_proc_desc *prodesc;
2185         FunctionCallInfo fcinfo;
2186         ReturnSetInfo *rsi;
2187         MemoryContext old_cxt;
2188
2189         if (!sv)
2190                 return;
2191
2192         prodesc = current_call_data->prodesc;
2193         fcinfo = current_call_data->fcinfo;
2194         rsi = (ReturnSetInfo *) fcinfo->resultinfo;
2195
2196         if (!prodesc->fn_retisset)
2197                 ereport(ERROR,
2198                                 (errcode(ERRCODE_SYNTAX_ERROR),
2199                                  errmsg("cannot use return_next in a non-SETOF function")));
2200
2201         if (prodesc->fn_retistuple &&
2202                 !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
2203                 ereport(ERROR,
2204                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
2205                                  errmsg("SETOF-composite-returning PL/Perl function "
2206                                                 "must call return_next with reference to hash")));
2207
2208         if (!current_call_data->ret_tdesc)
2209         {
2210                 TupleDesc       tupdesc;
2211
2212                 Assert(!current_call_data->tuple_store);
2213                 Assert(!current_call_data->attinmeta);
2214
2215                 /*
2216                  * This is the first call to return_next in the current PL/Perl
2217                  * function call, so memoize some lookups
2218                  */
2219                 if (prodesc->fn_retistuple)
2220                         (void) get_call_result_type(fcinfo, NULL, &tupdesc);
2221                 else
2222                         tupdesc = rsi->expectedDesc;
2223
2224                 /*
2225                  * Make sure the tuple_store and ret_tdesc are sufficiently
2226                  * long-lived.
2227                  */
2228                 old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
2229
2230                 current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
2231                 current_call_data->tuple_store =
2232                         tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
2233                                                                   false, work_mem);
2234                 if (prodesc->fn_retistuple)
2235                 {
2236                         current_call_data->attinmeta =
2237                                 TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
2238                 }
2239
2240                 MemoryContextSwitchTo(old_cxt);
2241         }
2242
2243         /*
2244          * Producing the tuple we want to return requires making plenty of
2245          * palloc() allocations that are not cleaned up. Since this function can
2246          * be called many times before the current memory context is reset, we
2247          * need to do those allocations in a temporary context.
2248          */
2249         if (!current_call_data->tmp_cxt)
2250         {
2251                 current_call_data->tmp_cxt =
2252                         AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
2253                                                                   "PL/Perl return_next temporary cxt",
2254                                                                   ALLOCSET_DEFAULT_MINSIZE,
2255                                                                   ALLOCSET_DEFAULT_INITSIZE,
2256                                                                   ALLOCSET_DEFAULT_MAXSIZE);
2257         }
2258
2259         old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
2260
2261         if (prodesc->fn_retistuple)
2262         {
2263                 HeapTuple       tuple;
2264
2265                 tuple = plperl_build_tuple_result((HV *) SvRV(sv),
2266                                                                                   current_call_data->attinmeta);
2267                 tuplestore_puttuple(current_call_data->tuple_store, tuple);
2268         }
2269         else
2270         {
2271                 Datum           ret;
2272                 bool            isNull;
2273
2274                 if (SvOK(sv))
2275                 {
2276                         if (prodesc->fn_retisarray && SvROK(sv) &&
2277                                 SvTYPE(SvRV(sv)) == SVt_PVAV)
2278                         {
2279                                 sv = plperl_convert_to_pg_array(sv);
2280                         }
2281
2282                         ret = InputFunctionCall(&prodesc->result_in_func,
2283                                                                         sv2text_mbverified(sv),
2284                                                                         prodesc->result_typioparam, -1);
2285                         isNull = false;
2286                 }
2287                 else
2288                 {
2289                         ret = InputFunctionCall(&prodesc->result_in_func, NULL,
2290                                                                         prodesc->result_typioparam, -1);
2291                         isNull = true;
2292                 }
2293
2294                 tuplestore_putvalues(current_call_data->tuple_store,
2295                                                          current_call_data->ret_tdesc,
2296                                                          &ret, &isNull);
2297         }
2298
2299         MemoryContextSwitchTo(old_cxt);
2300         MemoryContextReset(current_call_data->tmp_cxt);
2301 }
2302
2303
2304 SV *
2305 plperl_spi_query(char *query)
2306 {
2307         SV                 *cursor;
2308
2309         /*
2310          * Execute the query inside a sub-transaction, so we can cope with errors
2311          * sanely
2312          */
2313         MemoryContext oldcontext = CurrentMemoryContext;
2314         ResourceOwner oldowner = CurrentResourceOwner;
2315
2316         check_spi_usage_allowed();
2317
2318         BeginInternalSubTransaction(NULL);
2319         /* Want to run inside function's memory context */
2320         MemoryContextSwitchTo(oldcontext);
2321
2322         PG_TRY();
2323         {
2324                 void       *plan;
2325                 Portal          portal;
2326
2327                 /* Create a cursor for the query */
2328                 plan = SPI_prepare(query, 0, NULL);
2329                 if (plan == NULL)
2330                         elog(ERROR, "SPI_prepare() failed:%s",
2331                                  SPI_result_code_string(SPI_result));
2332
2333                 portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
2334                 SPI_freeplan(plan);
2335                 if (portal == NULL)
2336                         elog(ERROR, "SPI_cursor_open() failed:%s",
2337                                  SPI_result_code_string(SPI_result));
2338                 cursor = newSVstring(portal->name);
2339
2340                 /* Commit the inner transaction, return to outer xact context */
2341                 ReleaseCurrentSubTransaction();
2342                 MemoryContextSwitchTo(oldcontext);
2343                 CurrentResourceOwner = oldowner;
2344
2345                 /*
2346                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2347                  * in case it did, make sure we remain connected.
2348                  */
2349                 SPI_restore_connection();
2350         }
2351         PG_CATCH();
2352         {
2353                 ErrorData  *edata;
2354
2355                 /* Save error info */
2356                 MemoryContextSwitchTo(oldcontext);
2357                 edata = CopyErrorData();
2358                 FlushErrorState();
2359
2360                 /* Abort the inner transaction */
2361                 RollbackAndReleaseCurrentSubTransaction();
2362                 MemoryContextSwitchTo(oldcontext);
2363                 CurrentResourceOwner = oldowner;
2364
2365                 /*
2366                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2367                  * have left us in a disconnected state.  We need this hack to return
2368                  * to connected state.
2369                  */
2370                 SPI_restore_connection();
2371
2372                 /* Punt the error to Perl */
2373                 croak("%s", edata->message);
2374
2375                 /* Can't get here, but keep compiler quiet */
2376                 return NULL;
2377         }
2378         PG_END_TRY();
2379
2380         return cursor;
2381 }
2382
2383
2384 SV *
2385 plperl_spi_fetchrow(char *cursor)
2386 {
2387         SV                 *row;
2388
2389         /*
2390          * Execute the FETCH inside a sub-transaction, so we can cope with errors
2391          * sanely
2392          */
2393         MemoryContext oldcontext = CurrentMemoryContext;
2394         ResourceOwner oldowner = CurrentResourceOwner;
2395
2396         check_spi_usage_allowed();
2397
2398         BeginInternalSubTransaction(NULL);
2399         /* Want to run inside function's memory context */
2400         MemoryContextSwitchTo(oldcontext);
2401
2402         PG_TRY();
2403         {
2404                 Portal          p = SPI_cursor_find(cursor);
2405
2406                 if (!p)
2407                 {
2408                         row = &PL_sv_undef;
2409                 }
2410                 else
2411                 {
2412                         SPI_cursor_fetch(p, true, 1);
2413                         if (SPI_processed == 0)
2414                         {
2415                                 SPI_cursor_close(p);
2416                                 row = &PL_sv_undef;
2417                         }
2418                         else
2419                         {
2420                                 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
2421                                                                                          SPI_tuptable->tupdesc);
2422                         }
2423                         SPI_freetuptable(SPI_tuptable);
2424                 }
2425
2426                 /* Commit the inner transaction, return to outer xact context */
2427                 ReleaseCurrentSubTransaction();
2428                 MemoryContextSwitchTo(oldcontext);
2429                 CurrentResourceOwner = oldowner;
2430
2431                 /*
2432                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2433                  * in case it did, make sure we remain connected.
2434                  */
2435                 SPI_restore_connection();
2436         }
2437         PG_CATCH();
2438         {
2439                 ErrorData  *edata;
2440
2441                 /* Save error info */
2442                 MemoryContextSwitchTo(oldcontext);
2443                 edata = CopyErrorData();
2444                 FlushErrorState();
2445
2446                 /* Abort the inner transaction */
2447                 RollbackAndReleaseCurrentSubTransaction();
2448                 MemoryContextSwitchTo(oldcontext);
2449                 CurrentResourceOwner = oldowner;
2450
2451                 /*
2452                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2453                  * have left us in a disconnected state.  We need this hack to return
2454                  * to connected state.
2455                  */
2456                 SPI_restore_connection();
2457
2458                 /* Punt the error to Perl */
2459                 croak("%s", edata->message);
2460
2461                 /* Can't get here, but keep compiler quiet */
2462                 return NULL;
2463         }
2464         PG_END_TRY();
2465
2466         return row;
2467 }
2468
2469 void
2470 plperl_spi_cursor_close(char *cursor)
2471 {
2472         Portal          p;
2473
2474         check_spi_usage_allowed();
2475
2476         p = SPI_cursor_find(cursor);
2477
2478         if (p)
2479                 SPI_cursor_close(p);
2480 }
2481
2482 SV *
2483 plperl_spi_prepare(char *query, int argc, SV **argv)
2484 {
2485         plperl_query_desc *qdesc;
2486         plperl_query_entry *hash_entry;
2487         bool            found;
2488         void       *plan;
2489         int                     i;
2490
2491         MemoryContext oldcontext = CurrentMemoryContext;
2492         ResourceOwner oldowner = CurrentResourceOwner;
2493
2494         check_spi_usage_allowed();
2495
2496         BeginInternalSubTransaction(NULL);
2497         MemoryContextSwitchTo(oldcontext);
2498
2499         /************************************************************
2500          * Allocate the new querydesc structure
2501          ************************************************************/
2502         qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
2503         MemSet(qdesc, 0, sizeof(plperl_query_desc));
2504         snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
2505         qdesc->nargs = argc;
2506         qdesc->argtypes = (Oid *) malloc(argc * sizeof(Oid));
2507         qdesc->arginfuncs = (FmgrInfo *) malloc(argc * sizeof(FmgrInfo));
2508         qdesc->argtypioparams = (Oid *) malloc(argc * sizeof(Oid));
2509
2510         PG_TRY();
2511         {
2512                 /************************************************************
2513                  * Resolve argument type names and then look them up by oid
2514                  * in the system cache, and remember the required information
2515                  * for input conversion.
2516                  ************************************************************/
2517                 for (i = 0; i < argc; i++)
2518                 {
2519                         Oid                     typId,
2520                                                 typInput,
2521                                                 typIOParam;
2522                         int32           typmod;
2523
2524                         parseTypeString(SvPV_nolen(argv[i]), &typId, &typmod);
2525
2526                         getTypeInputInfo(typId, &typInput, &typIOParam);
2527
2528                         qdesc->argtypes[i] = typId;
2529                         perm_fmgr_info(typInput, &(qdesc->arginfuncs[i]));
2530                         qdesc->argtypioparams[i] = typIOParam;
2531                 }
2532
2533                 /************************************************************
2534                  * Prepare the plan and check for errors
2535                  ************************************************************/
2536                 plan = SPI_prepare(query, argc, qdesc->argtypes);
2537
2538                 if (plan == NULL)
2539                         elog(ERROR, "SPI_prepare() failed:%s",
2540                                  SPI_result_code_string(SPI_result));
2541
2542                 /************************************************************
2543                  * Save the plan into permanent memory (right now it's in the
2544                  * SPI procCxt, which will go away at function end).
2545                  ************************************************************/
2546                 qdesc->plan = SPI_saveplan(plan);
2547                 if (qdesc->plan == NULL)
2548                         elog(ERROR, "SPI_saveplan() failed: %s",
2549                                  SPI_result_code_string(SPI_result));
2550
2551                 /* Release the procCxt copy to avoid within-function memory leak */
2552                 SPI_freeplan(plan);
2553
2554                 /* Commit the inner transaction, return to outer xact context */
2555                 ReleaseCurrentSubTransaction();
2556                 MemoryContextSwitchTo(oldcontext);
2557                 CurrentResourceOwner = oldowner;
2558
2559                 /*
2560                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2561                  * in case it did, make sure we remain connected.
2562                  */
2563                 SPI_restore_connection();
2564         }
2565         PG_CATCH();
2566         {
2567                 ErrorData  *edata;
2568
2569                 free(qdesc->argtypes);
2570                 free(qdesc->arginfuncs);
2571                 free(qdesc->argtypioparams);
2572                 free(qdesc);
2573
2574                 /* Save error info */
2575                 MemoryContextSwitchTo(oldcontext);
2576                 edata = CopyErrorData();
2577                 FlushErrorState();
2578
2579                 /* Abort the inner transaction */
2580                 RollbackAndReleaseCurrentSubTransaction();
2581                 MemoryContextSwitchTo(oldcontext);
2582                 CurrentResourceOwner = oldowner;
2583
2584                 /*
2585                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2586                  * have left us in a disconnected state.  We need this hack to return
2587                  * to connected state.
2588                  */
2589                 SPI_restore_connection();
2590
2591                 /* Punt the error to Perl */
2592                 croak("%s", edata->message);
2593
2594                 /* Can't get here, but keep compiler quiet */
2595                 return NULL;
2596         }
2597         PG_END_TRY();
2598
2599         /************************************************************
2600          * Insert a hashtable entry for the plan and return
2601          * the key to the caller.
2602          ************************************************************/
2603
2604         hash_entry = hash_search(plperl_query_hash, qdesc->qname,
2605                                                          HASH_ENTER, &found);
2606         hash_entry->query_data = qdesc;
2607
2608         return newSVstring(qdesc->qname);
2609 }
2610
2611 HV *
2612 plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
2613 {
2614         HV                 *ret_hv;
2615         SV                **sv;
2616         int                     i,
2617                                 limit,
2618                                 spi_rv;
2619         char       *nulls;
2620         Datum      *argvalues;
2621         plperl_query_desc *qdesc;
2622         plperl_query_entry *hash_entry;
2623
2624         /*
2625          * Execute the query inside a sub-transaction, so we can cope with errors
2626          * sanely
2627          */
2628         MemoryContext oldcontext = CurrentMemoryContext;
2629         ResourceOwner oldowner = CurrentResourceOwner;
2630
2631         check_spi_usage_allowed();
2632
2633         BeginInternalSubTransaction(NULL);
2634         /* Want to run inside function's memory context */
2635         MemoryContextSwitchTo(oldcontext);
2636
2637         PG_TRY();
2638         {
2639                 /************************************************************
2640                  * Fetch the saved plan descriptor, see if it's o.k.
2641                  ************************************************************/
2642
2643                 hash_entry = hash_search(plperl_query_hash, query,
2644                                                                  HASH_FIND, NULL);
2645                 if (hash_entry == NULL)
2646                         elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2647
2648                 qdesc = hash_entry->query_data;
2649
2650                 if (qdesc == NULL)
2651                         elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value vanished");
2652
2653                 if (qdesc->nargs != argc)
2654                         elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
2655                                  qdesc->nargs, argc);
2656
2657                 /************************************************************
2658                  * Parse eventual attributes
2659                  ************************************************************/
2660                 limit = 0;
2661                 if (attr != NULL)
2662                 {
2663                         sv = hv_fetch_string(attr, "limit");
2664                         if (*sv && SvIOK(*sv))
2665                                 limit = SvIV(*sv);
2666                 }
2667                 /************************************************************
2668                  * Set up arguments
2669                  ************************************************************/
2670                 if (argc > 0)
2671                 {
2672                         nulls = (char *) palloc(argc);
2673                         argvalues = (Datum *) palloc(argc * sizeof(Datum));
2674                 }
2675                 else
2676                 {
2677                         nulls = NULL;
2678                         argvalues = NULL;
2679                 }
2680
2681                 for (i = 0; i < argc; i++)
2682                 {
2683                         if (SvOK(argv[i]))
2684                         {
2685                                 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2686                                                                                                  sv2text_mbverified(argv[i]),
2687                                                                                                  qdesc->argtypioparams[i],
2688                                                                                                  -1);
2689                                 nulls[i] = ' ';
2690                         }
2691                         else
2692                         {
2693                                 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2694                                                                                                  NULL,
2695                                                                                                  qdesc->argtypioparams[i],
2696                                                                                                  -1);
2697                                 nulls[i] = 'n';
2698                         }
2699                 }
2700
2701                 /************************************************************
2702                  * go
2703                  ************************************************************/
2704                 spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
2705                                                          current_call_data->prodesc->fn_readonly, limit);
2706                 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
2707                                                                                                  spi_rv);
2708                 if (argc > 0)
2709                 {
2710                         pfree(argvalues);
2711                         pfree(nulls);
2712                 }
2713
2714                 /* Commit the inner transaction, return to outer xact context */
2715                 ReleaseCurrentSubTransaction();
2716                 MemoryContextSwitchTo(oldcontext);
2717                 CurrentResourceOwner = oldowner;
2718
2719                 /*
2720                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2721                  * in case it did, make sure we remain connected.
2722                  */
2723                 SPI_restore_connection();
2724         }
2725         PG_CATCH();
2726         {
2727                 ErrorData  *edata;
2728
2729                 /* Save error info */
2730                 MemoryContextSwitchTo(oldcontext);
2731                 edata = CopyErrorData();
2732                 FlushErrorState();
2733
2734                 /* Abort the inner transaction */
2735                 RollbackAndReleaseCurrentSubTransaction();
2736                 MemoryContextSwitchTo(oldcontext);
2737                 CurrentResourceOwner = oldowner;
2738
2739                 /*
2740                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2741                  * have left us in a disconnected state.  We need this hack to return
2742                  * to connected state.
2743                  */
2744                 SPI_restore_connection();
2745
2746                 /* Punt the error to Perl */
2747                 croak("%s", edata->message);
2748
2749                 /* Can't get here, but keep compiler quiet */
2750                 return NULL;
2751         }
2752         PG_END_TRY();
2753
2754         return ret_hv;
2755 }
2756
2757 SV *
2758 plperl_spi_query_prepared(char *query, int argc, SV **argv)
2759 {
2760         int                     i;
2761         char       *nulls;
2762         Datum      *argvalues;
2763         plperl_query_desc *qdesc;
2764         plperl_query_entry *hash_entry;
2765         SV                 *cursor;
2766         Portal          portal = NULL;
2767
2768         /*
2769          * Execute the query inside a sub-transaction, so we can cope with errors
2770          * sanely
2771          */
2772         MemoryContext oldcontext = CurrentMemoryContext;
2773         ResourceOwner oldowner = CurrentResourceOwner;
2774
2775         check_spi_usage_allowed();
2776
2777         BeginInternalSubTransaction(NULL);
2778         /* Want to run inside function's memory context */
2779         MemoryContextSwitchTo(oldcontext);
2780
2781         PG_TRY();
2782         {
2783                 /************************************************************
2784                  * Fetch the saved plan descriptor, see if it's o.k.
2785                  ************************************************************/
2786                 hash_entry = hash_search(plperl_query_hash, query,
2787                                                                  HASH_FIND, NULL);
2788                 if (hash_entry == NULL)
2789                         elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2790
2791                 qdesc = hash_entry->query_data;
2792
2793                 if (qdesc == NULL)
2794                         elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value vanished");
2795
2796                 if (qdesc->nargs != argc)
2797                         elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
2798                                  qdesc->nargs, argc);
2799
2800                 /************************************************************
2801                  * Set up arguments
2802                  ************************************************************/
2803                 if (argc > 0)
2804                 {
2805                         nulls = (char *) palloc(argc);
2806                         argvalues = (Datum *) palloc(argc * sizeof(Datum));
2807                 }
2808                 else
2809                 {
2810                         nulls = NULL;
2811                         argvalues = NULL;
2812                 }
2813
2814                 for (i = 0; i < argc; i++)
2815                 {
2816                         if (SvOK(argv[i]))
2817                         {
2818                                 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2819                                                                                                  sv2text_mbverified(argv[i]),
2820                                                                                                  qdesc->argtypioparams[i],
2821                                                                                                  -1);
2822                                 nulls[i] = ' ';
2823                         }
2824                         else
2825                         {
2826                                 argvalues[i] = InputFunctionCall(&qdesc->arginfuncs[i],
2827                                                                                                  NULL,
2828                                                                                                  qdesc->argtypioparams[i],
2829                                                                                                  -1);
2830                                 nulls[i] = 'n';
2831                         }
2832                 }
2833
2834                 /************************************************************
2835                  * go
2836                  ************************************************************/
2837                 portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
2838                                                                  current_call_data->prodesc->fn_readonly);
2839                 if (argc > 0)
2840                 {
2841                         pfree(argvalues);
2842                         pfree(nulls);
2843                 }
2844                 if (portal == NULL)
2845                         elog(ERROR, "SPI_cursor_open() failed:%s",
2846                                  SPI_result_code_string(SPI_result));
2847
2848                 cursor = newSVstring(portal->name);
2849
2850                 /* Commit the inner transaction, return to outer xact context */
2851                 ReleaseCurrentSubTransaction();
2852                 MemoryContextSwitchTo(oldcontext);
2853                 CurrentResourceOwner = oldowner;
2854
2855                 /*
2856                  * AtEOSubXact_SPI() should not have popped any SPI context, but just
2857                  * in case it did, make sure we remain connected.
2858                  */
2859                 SPI_restore_connection();
2860         }
2861         PG_CATCH();
2862         {
2863                 ErrorData  *edata;
2864
2865                 /* Save error info */
2866                 MemoryContextSwitchTo(oldcontext);
2867                 edata = CopyErrorData();
2868                 FlushErrorState();
2869
2870                 /* Abort the inner transaction */
2871                 RollbackAndReleaseCurrentSubTransaction();
2872                 MemoryContextSwitchTo(oldcontext);
2873                 CurrentResourceOwner = oldowner;
2874
2875                 /*
2876                  * If AtEOSubXact_SPI() popped any SPI context of the subxact, it will
2877                  * have left us in a disconnected state.  We need this hack to return
2878                  * to connected state.
2879                  */
2880                 SPI_restore_connection();
2881
2882                 /* Punt the error to Perl */
2883                 croak("%s", edata->message);
2884
2885                 /* Can't get here, but keep compiler quiet */
2886                 return NULL;
2887         }
2888         PG_END_TRY();
2889
2890         return cursor;
2891 }
2892
2893 void
2894 plperl_spi_freeplan(char *query)
2895 {
2896         void       *plan;
2897         plperl_query_desc *qdesc;
2898         plperl_query_entry *hash_entry;
2899
2900         check_spi_usage_allowed();
2901
2902         hash_entry = hash_search(plperl_query_hash, query,
2903                                                          HASH_FIND, NULL);
2904         if (hash_entry == NULL)
2905                 elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
2906
2907         qdesc = hash_entry->query_data;
2908
2909         if (qdesc == NULL)
2910                 elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value vanished");
2911
2912         /*
2913          * free all memory before SPI_freeplan, so if it dies, nothing will be
2914          * left over
2915          */
2916         hash_search(plperl_query_hash, query,
2917                                 HASH_REMOVE, NULL);
2918
2919         plan = qdesc->plan;
2920         free(qdesc->argtypes);
2921         free(qdesc->arginfuncs);
2922         free(qdesc->argtypioparams);
2923         free(qdesc);
2924
2925         SPI_freeplan(plan);
2926 }
2927
2928 /*
2929  * Create a new SV from a string assumed to be in the current database's
2930  * encoding.
2931  */
2932 static SV  *
2933 newSVstring(const char *str)
2934 {
2935         SV                 *sv;
2936
2937         sv = newSVpv(str, 0);
2938 #if PERL_BCDVERSION >= 0x5006000L
2939         if (GetDatabaseEncoding() == PG_UTF8)
2940                 SvUTF8_on(sv);
2941 #endif
2942         return sv;
2943 }
2944
2945 /*
2946  * Store an SV into a hash table under a key that is a string assumed to be
2947  * in the current database's encoding.
2948  */
2949 static SV **
2950 hv_store_string(HV *hv, const char *key, SV *val)
2951 {
2952         int32           klen = strlen(key);
2953
2954         /*
2955          * This seems nowhere documented, but under Perl 5.8.0 and up, hv_store()
2956          * recognizes a negative klen parameter as meaning a UTF-8 encoded key. It
2957          * does not appear that hashes track UTF-8-ness of keys at all in Perl
2958          * 5.6.
2959          */
2960 #if PERL_BCDVERSION >= 0x5008000L
2961         if (GetDatabaseEncoding() == PG_UTF8)
2962                 klen = -klen;
2963 #endif
2964         return hv_store(hv, key, klen, val, 0);
2965 }
2966
2967 /*
2968  * Fetch an SV from a hash table under a key that is a string assumed to be
2969  * in the current database's encoding.
2970  */
2971 static SV **
2972 hv_fetch_string(HV *hv, const char *key)
2973 {
2974         int32           klen = strlen(key);
2975
2976         /* See notes in hv_store_string */
2977 #if PERL_BCDVERSION >= 0x5008000L
2978         if (GetDatabaseEncoding() == PG_UTF8)
2979                 klen = -klen;
2980 #endif
2981         return hv_fetch(hv, key, klen, 0);
2982 }
2983
2984 /*
2985  * Provide function name for PL/Perl execution errors
2986  */
2987 static void
2988 plperl_exec_callback(void *arg)
2989 {
2990         char *procname = (char *) arg;
2991         if (procname)
2992                 errcontext("PL/Perl function \"%s\"", procname);
2993 }
2994
2995 /*
2996  * Provide function name for PL/Perl compilation errors
2997  */
2998 static void
2999 plperl_compile_callback(void *arg)
3000 {
3001         char *procname = (char *) arg;
3002         if (procname)
3003                 errcontext("compilation of PL/Perl function \"%s\"", procname);
3004 }
3005
3006 /*
3007  * Provide error context for the inline handler
3008  */
3009 static void
3010 plperl_inline_callback(void *arg)
3011 {
3012         errcontext("PL/Perl anonymous code block");
3013 }