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

   1 /**********************************************************************
   2  * plperl.c - perl as a procedural language for PostgreSQL
   3  *
   4  * IDENTIFICATION
   5  *
   6  *        This software is copyrighted by Mark Hollomon
   7  *        but is shameless cribbed from pltcl.c by Jan Wieck.
   8  *
   9  *        The author hereby grants permission  to  use,  copy,  modify,
  10  *        distribute,  and      license this software and its documentation
  11  *        for any purpose, provided that existing copyright notices are
  12  *        retained      in      all  copies  and  that  this notice is included
  13  *        verbatim in any distributions. No written agreement, license,
  14  *        or  royalty  fee      is required for any of the authorized uses.
  15  *        Modifications to this software may be  copyrighted  by  their
  16  *        author  and  need  not  follow  the licensing terms described
  17  *        here, provided that the new terms are  clearly  indicated  on
  18  *        the first page of each file where they apply.
  19  *
  20  *        IN NO EVENT SHALL THE AUTHOR OR DISTRIBUTORS BE LIABLE TO ANY
  21  *        PARTY  FOR  DIRECT,   INDIRECT,       SPECIAL,   INCIDENTAL,   OR
  22  *        CONSEQUENTIAL   DAMAGES  ARISING      OUT  OF  THE  USE  OF  THIS
  23  *        SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN
  24  *        IF  THE  AUTHOR  HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH
  25  *        DAMAGE.
  26  *
  27  *        THE  AUTHOR  AND      DISTRIBUTORS  SPECIFICALLY       DISCLAIM       ANY
  28  *        WARRANTIES,  INCLUDING,  BUT  NOT  LIMITED  TO,  THE  IMPLIED
  29  *        WARRANTIES  OF  MERCHANTABILITY,      FITNESS  FOR  A  PARTICULAR
  30  *        PURPOSE,      AND NON-INFRINGEMENT.  THIS SOFTWARE IS PROVIDED ON
  31  *        AN "AS IS" BASIS, AND THE AUTHOR      AND  DISTRIBUTORS  HAVE  NO
  32  *        OBLIGATION   TO       PROVIDE   MAINTENANCE,   SUPPORT,  UPDATES,
  33  *        ENHANCEMENTS, OR MODIFICATIONS.
  34  *
  35  * IDENTIFICATION
  36  *        $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.80 2005/07/06 22:33:39 momjian Exp $
  37  *
  38  **********************************************************************/
  39
  40 #include "postgres.h"
  41 /* Defined by Perl */
  42 #undef _
  43
  44 /* system stuff */
  45 #include <ctype.h>
  46 #include <fcntl.h>
  47 #include <unistd.h>
  48
  49 /* postgreSQL stuff */
  50 #include "commands/trigger.h"
  51 #include "executor/spi.h"
  52 #include "funcapi.h"
  53 #include "utils/lsyscache.h"
  54 #include "utils/memutils.h"
  55 #include "utils/typcache.h"
  56 #include "miscadmin.h"
  57 #include "mb/pg_wchar.h"
  58
  59 /* perl stuff */
  60 #include "EXTERN.h"
  61 #include "perl.h"
  62 #include "XSUB.h"
  63 #include "ppport.h"
  64
  65 /* just in case these symbols aren't provided */
  66 #ifndef pTHX_
  67 #define pTHX_
  68 #define pTHX void
  69 #endif
  70
  71
  72 /**********************************************************************
  73  * The information we cache about loaded procedures
  74  **********************************************************************/
  75 typedef struct plperl_proc_desc
  76 {
  77         char       *proname;
  78         TransactionId fn_xmin;
  79         CommandId       fn_cmin;
  80         bool            fn_readonly;
  81         bool            lanpltrusted;
  82         bool            fn_retistuple;  /* true, if function returns tuple */
  83         bool            fn_retisset;    /* true, if function returns set */
  84         Oid                     result_oid;             /* Oid of result type */
  85         FmgrInfo        result_in_func; /* I/O function and arg for result type */
  86         Oid                     result_typioparam;
  87         int                     nargs;
  88         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  89         bool            arg_is_rowtype[FUNC_MAX_ARGS];
  90         SV                 *reference;
  91         FunctionCallInfo caller_info;
  92         Tuplestorestate *tuple_store;
  93         TupleDesc tuple_desc;
  94 } plperl_proc_desc;
  95
  96
  97 /**********************************************************************
  98  * Global data
  99  **********************************************************************/
 100 static int      plperl_firstcall = 1;
 101 static bool plperl_safe_init_done = false;
 102 static PerlInterpreter *plperl_interp = NULL;
 103 static HV  *plperl_proc_hash = NULL;
 104
 105 static bool plperl_use_strict = false;
 106
 107 /* this is saved and restored by plperl_call_handler */
 108 static plperl_proc_desc *plperl_current_prodesc = NULL;
 109
 110 /**********************************************************************
 111  * Forward declarations
 112  **********************************************************************/
 113 static void plperl_init_all(void);
 114 static void plperl_init_interp(void);
 115
 116 Datum           plperl_call_handler(PG_FUNCTION_ARGS);
 117 Datum           plperl_validator(PG_FUNCTION_ARGS);
 118 void            plperl_init(void);
 119
 120 HV                 *plperl_spi_exec(char *query, int limit);
 121
 122 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 123
 124 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
 125 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 126
 127 static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
 128 static void plperl_init_shared_libs(pTHX);
 129 static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
 130
 131 void plperl_return_next(SV *);
 132
 133 /*
 134  * This routine is a crock, and so is everyplace that calls it.  The problem
 135  * is that the cached form of plperl functions/queries is allocated permanently
 136  * (mostly via malloc()) and never released until backend exit.  Subsidiary
 137  * data structures such as fmgr info records therefore must live forever
 138  * as well.  A better implementation would store all this stuff in a per-
 139  * function memory context that could be reclaimed at need.  In the meantime,
 140  * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
 141  * it might allocate, and whatever the eventual function might allocate using
 142  * fn_mcxt, will live forever too.
 143  */
 144 static void
 145 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
 146 {
 147         fmgr_info_cxt(functionId, finfo, TopMemoryContext);
 148 }
 149
 150
 151 /* Perform initialization during postmaster startup. */
 152
 153 void
 154 plperl_init(void)
 155 {
 156         if (!plperl_firstcall)
 157                 return;
 158
 159         DefineCustomBoolVariable(
 160                 "plperl.use_strict",
 161                 "If true, will compile trusted and untrusted perl code in strict mode",
 162                 NULL,
 163                 &plperl_use_strict,
 164                 PGC_USERSET,
 165                 NULL, NULL);
 166
 167         EmitWarningsOnPlaceholders("plperl");
 168
 169         plperl_init_interp();
 170         plperl_firstcall = 0;
 171 }
 172
 173
 174 /* Perform initialization during backend startup. */
 175
 176 static void
 177 plperl_init_all(void)
 178 {
 179         if (plperl_firstcall)
 180                 plperl_init();
 181
 182         /* We don't need to do anything yet when a new backend starts. */
 183 }
 184
 185
 186 static void
 187 plperl_init_interp(void)
 188 {
 189         static char        *loose_embedding[3] = {
 190                 "", "-e",
 191                 /* all one string follows (no commas please) */
 192                 "SPI::bootstrap(); use vars qw(%_SHARED);"
 193                 "sub ::plperl_warn { my $msg = shift; &elog(&NOTICE, $msg); } "
 194                 "$SIG{__WARN__} = \\&::plperl_warn; "
 195                 "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
 196         };
 197
 198         static char        *strict_embedding[3] = {
 199                 "", "-e",
 200                 /* all one string follows (no commas please) */
 201                 "SPI::bootstrap(); use vars qw(%_SHARED);"
 202                 "sub ::plperl_warn { my $msg = shift; &elog(&NOTICE, $msg); } "
 203                 "$SIG{__WARN__} = \\&::plperl_warn; "
 204                 "sub ::mkunsafefunc {return eval("
 205                 "qq[ sub { use strict; $_[0] $_[1] } ]); }"
 206         };
 207
 208         plperl_interp = perl_alloc();
 209         if (!plperl_interp)
 210                 elog(ERROR, "could not allocate Perl interpreter");
 211
 212         perl_construct(plperl_interp);
 213         perl_parse(plperl_interp, plperl_init_shared_libs, 3 ,
 214                            (plperl_use_strict ? strict_embedding : loose_embedding), NULL);
 215         perl_run(plperl_interp);
 216
 217         plperl_proc_hash = newHV();
 218 }
 219
 220
 221 static void
 222 plperl_safe_init(void)
 223 {
 224         static char *safe_module =
 225         "require Safe; $Safe::VERSION";
 226
 227         static char *common_safe_ok =
 228         "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
 229         "$PLContainer->permit_only(':default');"
 230         "$PLContainer->permit(qw[:base_math !:base_io sort time]);"
 231         "$PLContainer->share(qw[&elog &spi_exec_query &return_next "
 232         "&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
 233                            ;
 234
 235         static char * strict_safe_ok =
 236                 "$PLContainer->permit('require');$PLContainer->reval('use strict;');"
 237                 "$PLContainer->deny('require');"
 238                 "sub ::mksafefunc { return $PLContainer->reval(qq[ "
 239                 "             sub { BEGIN { strict->import(); } $_[0] $_[1]}]); }"
 240                 ;
 241
 242         static char * loose_safe_ok =
 243                 "sub ::mksafefunc { return $PLContainer->reval(qq[ "
 244                 "             sub { $_[0] $_[1]}]); }"
 245                 ;
 246
 247         static char *safe_bad =
 248         "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
 249         "$PLContainer->permit_only(':default');"
 250         "$PLContainer->share(qw[&elog &ERROR ]);"
 251         "sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
 252         "elog(ERROR,'trusted Perl functions disabled - "
 253         "please upgrade Perl Safe module to version 2.09 or later');}]); }"
 254                            ;
 255
 256         SV                 *res;
 257         double          safe_version;
 258
 259         res = eval_pv(safe_module, FALSE);      /* TRUE = croak if failure */
 260
 261         safe_version = SvNV(res);
 262
 263         /*
 264          * We actually want to reject safe_version < 2.09, but it's risky to
 265          * assume that floating-point comparisons are exact, so use a slightly
 266          * smaller comparison value.
 267          */
 268         if (safe_version < 2.0899 )
 269         {
 270                 /* not safe, so disallow all trusted funcs */
 271                 eval_pv(safe_bad, FALSE);
 272         }
 273         else
 274         {
 275                 eval_pv(common_safe_ok, FALSE);
 276                 eval_pv((plperl_use_strict ? strict_safe_ok : loose_safe_ok), FALSE);
 277         }
 278
 279         plperl_safe_init_done = true;
 280 }
 281
 282
 283 /*
 284  * Perl likes to put a newline after its error messages; clean up such
 285  */
 286 static char *
 287 strip_trailing_ws(const char *msg)
 288 {
 289         char   *res = pstrdup(msg);
 290         int             len = strlen(res);
 291
 292         while (len > 0 && isspace((unsigned char) res[len-1]))
 293                 res[--len] = '\0';
 294         return res;
 295 }
 296
 297
 298 /* Build a tuple from a hash. */
 299
 300 static HeapTuple
 301 plperl_build_tuple_result(HV *perlhash, AttInMetadata *attinmeta)
 302 {
 303         TupleDesc       td = attinmeta->tupdesc;
 304         char      **values;
 305         SV                 *val;
 306         char       *key;
 307         I32                     klen;
 308         HeapTuple       tup;
 309
 310         values = (char **) palloc0(td->natts * sizeof(char *));
 311
 312         hv_iterinit(perlhash);
 313         while ((val = hv_iternextsv(perlhash, &key, &klen)))
 314         {
 315                 int     attn = SPI_fnumber(td, key);
 316
 317                 if (attn <= 0 || td->attrs[attn - 1]->attisdropped)
 318                         ereport(ERROR,
 319                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 320                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 321                                                         key)));
 322                 if (SvOK(val) && SvTYPE(val) != SVt_NULL)
 323                         values[attn - 1] = SvPV(val, PL_na);
 324         }
 325         hv_iterinit(perlhash);
 326
 327         tup = BuildTupleFromCStrings(attinmeta, values);
 328         pfree(values);
 329         return tup;
 330 }
 331
 332
 333 /* Set up the arguments for a trigger call. */
 334
 335 static SV  *
 336 plperl_trigger_build_args(FunctionCallInfo fcinfo)
 337 {
 338         TriggerData *tdata;
 339         TupleDesc       tupdesc;
 340         int                     i;
 341         char       *level;
 342         char       *event;
 343         char       *relid;
 344         char       *when;
 345         HV                 *hv;
 346
 347         hv = newHV();
 348
 349         tdata = (TriggerData *) fcinfo->context;
 350         tupdesc = tdata->tg_relation->rd_att;
 351
 352         relid = DatumGetCString(
 353                                 DirectFunctionCall1(oidout,
 354                                                                         ObjectIdGetDatum(tdata->tg_relation->rd_id)
 355                                 )
 356                         );
 357
 358         hv_store(hv, "name", 4, newSVpv(tdata->tg_trigger->tgname, 0), 0);
 359         hv_store(hv, "relid", 5, newSVpv(relid, 0), 0);
 360
 361         if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
 362         {
 363                 event = "INSERT";
 364                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 365                         hv_store(hv, "new", 3,
 366                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 367                                          0);
 368         }
 369         else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
 370         {
 371                 event = "DELETE";
 372                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 373                         hv_store(hv, "old", 3,
 374                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 375                                          0);
 376         }
 377         else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
 378         {
 379                 event = "UPDATE";
 380                 if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 381                 {
 382                         hv_store(hv, "old", 3,
 383                                          plperl_hash_from_tuple(tdata->tg_trigtuple, tupdesc),
 384                                          0);
 385                         hv_store(hv, "new", 3,
 386                                          plperl_hash_from_tuple(tdata->tg_newtuple, tupdesc),
 387                                          0);
 388                 }
 389         }
 390         else
 391                 event = "UNKNOWN";
 392
 393         hv_store(hv, "event", 5, newSVpv(event, 0), 0);
 394         hv_store(hv, "argc", 4, newSViv(tdata->tg_trigger->tgnargs), 0);
 395
 396         if (tdata->tg_trigger->tgnargs > 0)
 397         {
 398                 AV *av = newAV();
 399                 for (i=0; i < tdata->tg_trigger->tgnargs; i++)
 400                         av_push(av, newSVpv(tdata->tg_trigger->tgargs[i], 0));
 401                 hv_store(hv, "args", 4, newRV_noinc((SV *)av), 0);
 402         }
 403
 404         hv_store(hv, "relname", 7,
 405                          newSVpv(SPI_getrelname(tdata->tg_relation), 0), 0);
 406
 407         if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
 408                 when = "BEFORE";
 409         else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
 410                 when = "AFTER";
 411         else
 412                 when = "UNKNOWN";
 413         hv_store(hv, "when", 4, newSVpv(when, 0), 0);
 414
 415         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 416                 level = "ROW";
 417         else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
 418                 level = "STATEMENT";
 419         else
 420                 level = "UNKNOWN";
 421         hv_store(hv, "level", 5, newSVpv(level, 0), 0);
 422
 423         return newRV_noinc((SV*)hv);
 424 }
 425
 426
 427 /* Set up the new tuple returned from a trigger. */
 428
 429 static HeapTuple
 430 plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 431 {
 432         SV                **svp;
 433         HV                 *hvNew;
 434         HeapTuple       rtup;
 435         SV                 *val;
 436         char       *key;
 437         I32                     klen;
 438         int                     slotsused;
 439         int                *modattrs;
 440         Datum      *modvalues;
 441         char       *modnulls;
 442
 443         TupleDesc       tupdesc;
 444
 445         tupdesc = tdata->tg_relation->rd_att;
 446
 447         svp = hv_fetch(hvTD, "new", 3, FALSE);
 448         if (!svp)
 449                 ereport(ERROR,
 450                                 (errcode(ERRCODE_UNDEFINED_COLUMN),
 451                                  errmsg("$_TD->{new} does not exist")));
 452         if (!SvOK(*svp) || SvTYPE(*svp) != SVt_RV || SvTYPE(SvRV(*svp)) != SVt_PVHV)
 453                 ereport(ERROR,
 454                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
 455                                  errmsg("$_TD->{new} is not a hash reference")));
 456         hvNew = (HV *) SvRV(*svp);
 457
 458         modattrs = palloc(tupdesc->natts * sizeof(int));
 459         modvalues = palloc(tupdesc->natts * sizeof(Datum));
 460         modnulls = palloc(tupdesc->natts * sizeof(char));
 461         slotsused = 0;
 462
 463         hv_iterinit(hvNew);
 464         while ((val = hv_iternextsv(hvNew, &key, &klen)))
 465         {
 466                 int                     attn = SPI_fnumber(tupdesc, key);
 467
 468                 if (attn <= 0 || tupdesc->attrs[attn - 1]->attisdropped)
 469                         ereport(ERROR,
 470                                         (errcode(ERRCODE_UNDEFINED_COLUMN),
 471                                          errmsg("Perl hash contains nonexistent column \"%s\"",
 472                                                         key)));
 473                 if (SvOK(val) && SvTYPE(val) != SVt_NULL)
 474                 {
 475                         Oid                     typinput;
 476                         Oid                     typioparam;
 477                         FmgrInfo        finfo;
 478
 479                         /* XXX would be better to cache these lookups */
 480                         getTypeInputInfo(tupdesc->attrs[attn - 1]->atttypid,
 481                                                          &typinput, &typioparam);
 482                         fmgr_info(typinput, &finfo);
 483                         modvalues[slotsused] = FunctionCall3(&finfo,
 484                                                                                  CStringGetDatum(SvPV(val, PL_na)),
 485                                                                                  ObjectIdGetDatum(typioparam),
 486                                                  Int32GetDatum(tupdesc->attrs[attn - 1]->atttypmod));
 487                         modnulls[slotsused] = ' ';
 488                 }
 489                 else
 490                 {
 491                         modvalues[slotsused] = (Datum) 0;
 492                         modnulls[slotsused] = 'n';
 493                 }
 494                 modattrs[slotsused] = attn;
 495                 slotsused++;
 496         }
 497         hv_iterinit(hvNew);
 498
 499         rtup = SPI_modifytuple(tdata->tg_relation, otup, slotsused,
 500                                                    modattrs, modvalues, modnulls);
 501
 502         pfree(modattrs);
 503         pfree(modvalues);
 504         pfree(modnulls);
 505
 506         if (rtup == NULL)
 507                 elog(ERROR, "SPI_modifytuple failed: %s",
 508                          SPI_result_code_string(SPI_result));
 509
 510         return rtup;
 511 }
 512
 513
 514 /*
 515  * This is the only externally-visible part of the plperl call interface.
 516  * The Postgres function and trigger managers call it to execute a
 517  * perl function.
 518  */
 519 PG_FUNCTION_INFO_V1(plperl_call_handler);
 520
 521 Datum
 522 plperl_call_handler(PG_FUNCTION_ARGS)
 523 {
 524         Datum retval;
 525         plperl_proc_desc *save_prodesc;
 526
 527         plperl_init_all();
 528
 529         save_prodesc = plperl_current_prodesc;
 530
 531         PG_TRY();
 532         {
 533                 if (CALLED_AS_TRIGGER(fcinfo))
 534                         retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
 535                 else
 536                         retval = plperl_func_handler(fcinfo);
 537         }
 538         PG_CATCH();
 539         {
 540                 plperl_current_prodesc = save_prodesc;
 541                 PG_RE_THROW();
 542         }
 543         PG_END_TRY();
 544
 545         plperl_current_prodesc = save_prodesc;
 546
 547         return retval;
 548 }
 549
 550 /*
 551  * This is the other externally visible function - it is called when CREATE
 552  * FUNCTION is issued to validate the function being created/replaced.
 553  */
 554 PG_FUNCTION_INFO_V1(plperl_validator);
 555
 556 Datum
 557 plperl_validator(PG_FUNCTION_ARGS)
 558 {
 559         Oid                     funcoid = PG_GETARG_OID(0);
 560         HeapTuple       tuple;
 561         Form_pg_proc proc;
 562         bool            istrigger = false;
 563         plperl_proc_desc *prodesc;
 564
 565         plperl_init_all();
 566
 567         /* Get the new function's pg_proc entry */
 568         tuple = SearchSysCache(PROCOID,
 569                                                    ObjectIdGetDatum(funcoid),
 570                                                    0, 0, 0);
 571         if (!HeapTupleIsValid(tuple))
 572                 elog(ERROR, "cache lookup failed for function %u", funcoid);
 573         proc = (Form_pg_proc) GETSTRUCT(tuple);
 574
 575         /* we assume OPAQUE with no arguments means a trigger */
 576         if (proc->prorettype == TRIGGEROID ||
 577                 (proc->prorettype == OPAQUEOID && proc->pronargs == 0))
 578                 istrigger = true;
 579
 580         ReleaseSysCache(tuple);
 581
 582         prodesc = compile_plperl_function(funcoid, istrigger);
 583
 584         /* the result of a validator is ignored */
 585         PG_RETURN_VOID();
 586 }
 587
 588
 589 /* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
 590  * supplied in s, and returns a reference to the closure. */
 591
 592 static SV  *
 593 plperl_create_sub(char *s, bool trusted)
 594 {
 595         dSP;
 596         SV                 *subref;
 597         int                     count;
 598
 599         if (trusted && !plperl_safe_init_done)
 600         {
 601                 plperl_safe_init();
 602                 SPAGAIN;
 603         }
 604
 605         ENTER;
 606         SAVETMPS;
 607         PUSHMARK(SP);
 608         XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
 609         XPUSHs(sv_2mortal(newSVpv(s, 0)));
 610         PUTBACK;
 611
 612         /*
 613          * G_KEEPERR seems to be needed here, else we don't recognize compile
 614          * errors properly.  Perhaps it's because there's another level of
 615          * eval inside mksafefunc?
 616          */
 617         count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
 618                                                  G_SCALAR | G_EVAL | G_KEEPERR);
 619         SPAGAIN;
 620
 621         if (count != 1)
 622         {
 623                 PUTBACK;
 624                 FREETMPS;
 625                 LEAVE;
 626                 elog(ERROR, "didn't get a return item from mksafefunc");
 627         }
 628
 629         if (SvTRUE(ERRSV))
 630         {
 631                 (void) POPs;
 632                 PUTBACK;
 633                 FREETMPS;
 634                 LEAVE;
 635                 ereport(ERROR,
 636                                 (errcode(ERRCODE_SYNTAX_ERROR),
 637                                  errmsg("creation of Perl function failed: %s",
 638                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 639         }
 640
 641         /*
 642          * need to make a deep copy of the return. it comes off the stack as a
 643          * temporary.
 644          */
 645         subref = newSVsv(POPs);
 646
 647         if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
 648         {
 649                 PUTBACK;
 650                 FREETMPS;
 651                 LEAVE;
 652
 653                 /*
 654                  * subref is our responsibility because it is not mortal
 655                  */
 656                 SvREFCNT_dec(subref);
 657                 elog(ERROR, "didn't get a code ref");
 658         }
 659
 660         PUTBACK;
 661         FREETMPS;
 662         LEAVE;
 663
 664         return subref;
 665 }
 666
 667
 668 /**********************************************************************
 669  * plperl_init_shared_libs()            -
 670  *
 671  * We cannot use the DynaLoader directly to get at the Opcode
 672  * module (used by Safe.pm). So, we link Opcode into ourselves
 673  * and do the initialization behind perl's back.
 674  *
 675  **********************************************************************/
 676
 677 EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
 678 EXTERN_C void boot_SPI(pTHX_ CV *cv);
 679
 680 static void
 681 plperl_init_shared_libs(pTHX)
 682 {
 683         char       *file = __FILE__;
 684
 685         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 686         newXS("SPI::bootstrap", boot_SPI, file);
 687 }
 688
 689
 690 static SV  *
 691 plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 692 {
 693         dSP;
 694         SV                 *retval;
 695         int                     i;
 696         int                     count;
 697         SV                      *sv;
 698
 699         ENTER;
 700         SAVETMPS;
 701
 702         PUSHMARK(SP);
 703
 704         XPUSHs(&PL_sv_undef); /* no trigger data */
 705
 706         for (i = 0; i < desc->nargs; i++)
 707         {
 708                 if (fcinfo->argnull[i])
 709                         XPUSHs(&PL_sv_undef);
 710                 else if (desc->arg_is_rowtype[i])
 711                 {
 712                         HeapTupleHeader td;
 713                         Oid                     tupType;
 714                         int32           tupTypmod;
 715                         TupleDesc       tupdesc;
 716                         HeapTupleData tmptup;
 717                         SV                 *hashref;
 718
 719                         td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
 720                         /* Extract rowtype info and find a tupdesc */
 721                         tupType = HeapTupleHeaderGetTypeId(td);
 722                         tupTypmod = HeapTupleHeaderGetTypMod(td);
 723                         tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
 724                         /* Build a temporary HeapTuple control structure */
 725                         tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
 726                         tmptup.t_data = td;
 727
 728                         hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
 729                         XPUSHs(sv_2mortal(hashref));
 730                 }
 731                 else
 732                 {
 733                         char       *tmp;
 734
 735                         tmp = DatumGetCString(FunctionCall1(&(desc->arg_out_func[i]),
 736                                                                                                 fcinfo->arg[i]));
 737                         sv = newSVpv(tmp, 0);
 738 #if PERL_BCDVERSION >= 0x5006000L
 739                         if (GetDatabaseEncoding() == PG_UTF8) SvUTF8_on(sv);
 740 #endif
 741                         XPUSHs(sv_2mortal(sv));
 742                         pfree(tmp);
 743                 }
 744         }
 745         PUTBACK;
 746
 747         /* Do NOT use G_KEEPERR here */
 748         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
 749
 750         SPAGAIN;
 751
 752         if (count != 1)
 753         {
 754                 PUTBACK;
 755                 FREETMPS;
 756                 LEAVE;
 757                 elog(ERROR, "didn't get a return item from function");
 758         }
 759
 760         if (SvTRUE(ERRSV))
 761         {
 762                 (void) POPs;
 763                 PUTBACK;
 764                 FREETMPS;
 765                 LEAVE;
 766                 /* XXX need to find a way to assign an errcode here */
 767                 ereport(ERROR,
 768                                 (errmsg("error from Perl function: %s",
 769                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 770         }
 771
 772         retval = newSVsv(POPs);
 773
 774         PUTBACK;
 775         FREETMPS;
 776         LEAVE;
 777
 778         return retval;
 779 }
 780
 781
 782 static SV  *
 783 plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
 784                                                           SV *td)
 785 {
 786         dSP;
 787         SV                 *retval;
 788         Trigger    *tg_trigger;
 789         int                     i;
 790         int                     count;
 791
 792         ENTER;
 793         SAVETMPS;
 794
 795         PUSHMARK(sp);
 796
 797         XPUSHs(td);
 798
 799         tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
 800         for (i = 0; i < tg_trigger->tgnargs; i++)
 801                 XPUSHs(sv_2mortal(newSVpv(tg_trigger->tgargs[i], 0)));
 802         PUTBACK;
 803
 804         /* Do NOT use G_KEEPERR here */
 805         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
 806
 807         SPAGAIN;
 808
 809         if (count != 1)
 810         {
 811                 PUTBACK;
 812                 FREETMPS;
 813                 LEAVE;
 814                 elog(ERROR, "didn't get a return item from trigger function");
 815         }
 816
 817         if (SvTRUE(ERRSV))
 818         {
 819                 (void) POPs;
 820                 PUTBACK;
 821                 FREETMPS;
 822                 LEAVE;
 823                 /* XXX need to find a way to assign an errcode here */
 824                 ereport(ERROR,
 825                                 (errmsg("error from Perl trigger function: %s",
 826                                                 strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 827         }
 828
 829         retval = newSVsv(POPs);
 830
 831         PUTBACK;
 832         FREETMPS;
 833         LEAVE;
 834
 835         return retval;
 836 }
 837
 838
 839 static Datum
 840 plperl_func_handler(PG_FUNCTION_ARGS)
 841 {
 842         plperl_proc_desc *prodesc;
 843         SV                 *perlret;
 844         Datum           retval;
 845         ReturnSetInfo *rsi;
 846
 847         if (SPI_connect() != SPI_OK_CONNECT)
 848                 elog(ERROR, "could not connect to SPI manager");
 849
 850         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
 851
 852         plperl_current_prodesc = prodesc;
 853         prodesc->caller_info = fcinfo;
 854         prodesc->tuple_store = 0;
 855         prodesc->tuple_desc = 0;
 856
 857         perlret = plperl_call_perl_func(prodesc, fcinfo);
 858
 859         /************************************************************
 860          * Disconnect from SPI manager and then create the return
 861          * values datum (if the input function does a palloc for it
 862          * this must not be allocated in the SPI memory context
 863          * because SPI_finish would free it).
 864          ************************************************************/
 865         if (SPI_finish() != SPI_OK_FINISH)
 866                 elog(ERROR, "SPI_finish() failed");
 867
 868         rsi = (ReturnSetInfo *)fcinfo->resultinfo;
 869
 870         if (prodesc->fn_retisset) {
 871                 if (!rsi || !IsA(rsi, ReturnSetInfo) ||
 872                         (rsi->allowedModes & SFRM_Materialize) == 0 ||
 873                         rsi->expectedDesc == NULL)
 874                 {
 875                         ereport(ERROR,
 876                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 877                                          errmsg("set-valued function called in context that "
 878                                                         "cannot accept a set")));
 879                 }
 880
 881                 /* If the Perl function returned an arrayref, we pretend that it
 882                  * called return_next() for each element of the array, to handle
 883                  * old SRFs that didn't know about return_next(). Any other sort
 884                  * of return value is an error. */
 885                 if (SvTYPE(perlret) == SVt_RV &&
 886                         SvTYPE(SvRV(perlret)) == SVt_PVAV)
 887                 {
 888                         int i = 0;
 889                         SV **svp = 0;
 890                         AV *rav = (AV *)SvRV(perlret);
 891                         while ((svp = av_fetch(rav, i, FALSE)) != NULL) {
 892                                 plperl_return_next(*svp);
 893                                 i++;
 894                         }
 895                 }
 896                 else if (SvTYPE(perlret) != SVt_NULL)
 897                 {
 898                         ereport(ERROR,
 899                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
 900                                          errmsg("set-returning Perl function must return "
 901                                                         "reference to array or use return_next")));
 902                 }
 903
 904                 rsi->returnMode = SFRM_Materialize;
 905                 if (prodesc->tuple_store) {
 906                         rsi->setResult = prodesc->tuple_store;
 907                         rsi->setDesc = prodesc->tuple_desc;
 908                 }
 909                 retval = (Datum)0;
 910         }
 911         else if (SvTYPE(perlret) == SVt_NULL)
 912         {
 913                 /* Return NULL if Perl code returned undef */
 914                 if (rsi && IsA(rsi, ReturnSetInfo))
 915                         rsi->isDone = ExprEndResult;
 916                 fcinfo->isnull = true;
 917                 retval = (Datum)0;
 918         }
 919         else if (prodesc->fn_retistuple)
 920         {
 921                 /* Return a perl hash converted to a Datum */
 922                 TupleDesc td;
 923                 AttInMetadata *attinmeta;
 924                 HeapTuple tup;
 925
 926                 if (!SvOK(perlret) || SvTYPE(perlret) != SVt_RV ||
 927                         SvTYPE(SvRV(perlret)) != SVt_PVHV)
 928                 {
 929                         ereport(ERROR,
 930                                         (errcode(ERRCODE_DATATYPE_MISMATCH),
 931                                          errmsg("composite-returning Perl function "
 932                                                         "must return reference to hash")));
 933                 }
 934
 935                 /* XXX should cache the attinmeta data instead of recomputing */
 936                 if (get_call_result_type(fcinfo, NULL, &td) != TYPEFUNC_COMPOSITE)
 937                 {
 938                         ereport(ERROR,
 939                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 940                                          errmsg("function returning record called in context "
 941                                                         "that cannot accept type record")));
 942                 }
 943
 944                 attinmeta = TupleDescGetAttInMetadata(td);
 945                 tup = plperl_build_tuple_result((HV *)SvRV(perlret), attinmeta);
 946                 retval = HeapTupleGetDatum(tup);
 947         }
 948         else
 949         {
 950                 /* Return a perl string converted to a Datum */
 951                 char *val = SvPV(perlret, PL_na);
 952                 retval = FunctionCall3(&prodesc->result_in_func,
 953                                                            CStringGetDatum(val),
 954                                                            ObjectIdGetDatum(prodesc->result_typioparam),
 955                                                            Int32GetDatum(-1));
 956         }
 957
 958         SvREFCNT_dec(perlret);
 959         return retval;
 960 }
 961
 962
 963 static Datum
 964 plperl_trigger_handler(PG_FUNCTION_ARGS)
 965 {
 966         plperl_proc_desc *prodesc;
 967         SV                 *perlret;
 968         Datum           retval;
 969         SV                 *svTD;
 970         HV                 *hvTD;
 971
 972         /* Connect to SPI manager */
 973         if (SPI_connect() != SPI_OK_CONNECT)
 974                 elog(ERROR, "could not connect to SPI manager");
 975
 976         /* Find or compile the function */
 977         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
 978
 979         plperl_current_prodesc = prodesc;
 980
 981         svTD = plperl_trigger_build_args(fcinfo);
 982         perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
 983         hvTD = (HV *) SvRV(svTD);
 984
 985         /************************************************************
 986         * Disconnect from SPI manager and then create the return
 987         * values datum (if the input function does a palloc for it
 988         * this must not be allocated in the SPI memory context
 989         * because SPI_finish would free it).
 990         ************************************************************/
 991         if (SPI_finish() != SPI_OK_FINISH)
 992                 elog(ERROR, "SPI_finish() failed");
 993
 994         if (!(perlret && SvOK(perlret) && SvTYPE(perlret) != SVt_NULL))
 995         {
 996                 /* undef result means go ahead with original tuple */
 997                 TriggerData *trigdata = ((TriggerData *) fcinfo->context);
 998
 999                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1000                         retval = (Datum) trigdata->tg_trigtuple;
1001                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1002                         retval = (Datum) trigdata->tg_newtuple;
1003                 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
1004                         retval = (Datum) trigdata->tg_trigtuple;
1005                 else
1006                         retval = (Datum) 0;     /* can this happen? */
1007         }
1008         else
1009         {
1010                 HeapTuple       trv;
1011                 char       *tmp;
1012
1013                 tmp = SvPV(perlret, PL_na);
1014
1015                 if (pg_strcasecmp(tmp, "SKIP") == 0)
1016                         trv = NULL;
1017                 else if (pg_strcasecmp(tmp, "MODIFY") == 0)
1018                 {
1019                         TriggerData *trigdata = (TriggerData *) fcinfo->context;
1020
1021                         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1022                                 trv = plperl_modify_tuple(hvTD, trigdata,
1023                                                                                   trigdata->tg_trigtuple);
1024                         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1025                                 trv = plperl_modify_tuple(hvTD, trigdata,
1026                                                                                   trigdata->tg_newtuple);
1027                         else
1028                         {
1029                                 ereport(WARNING,
1030                                                 (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1031                                                  errmsg("ignoring modified tuple in DELETE trigger")));
1032                                 trv = NULL;
1033                         }
1034                 }
1035                 else
1036                 {
1037                         ereport(ERROR,
1038                                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
1039                                          errmsg("result of Perl trigger function must be undef, "
1040                                                         "\"SKIP\" or \"MODIFY\"")));
1041                         trv = NULL;
1042                 }
1043                 retval = PointerGetDatum(trv);
1044         }
1045
1046         SvREFCNT_dec(svTD);
1047         if (perlret)
1048                 SvREFCNT_dec(perlret);
1049
1050         return retval;
1051 }
1052
1053
1054 static plperl_proc_desc *
1055 compile_plperl_function(Oid fn_oid, bool is_trigger)
1056 {
1057         HeapTuple       procTup;
1058         Form_pg_proc procStruct;
1059         char            internal_proname[64];
1060         int                     proname_len;
1061         plperl_proc_desc *prodesc = NULL;
1062         int                     i;
1063         SV                      **svp;
1064
1065         /* We'll need the pg_proc tuple in any case... */
1066         procTup = SearchSysCache(PROCOID,
1067                                                          ObjectIdGetDatum(fn_oid),
1068                                                          0, 0, 0);
1069         if (!HeapTupleIsValid(procTup))
1070                 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1071         procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1072
1073         /************************************************************
1074          * Build our internal proc name from the functions Oid
1075          ************************************************************/
1076         if (!is_trigger)
1077                 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
1078         else
1079                 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
1080
1081         proname_len = strlen(internal_proname);
1082
1083         /************************************************************
1084          * Lookup the internal proc name in the hashtable
1085          ************************************************************/
1086         svp = hv_fetch(plperl_proc_hash, internal_proname, proname_len, FALSE);
1087         if (svp)
1088         {
1089                 bool            uptodate;
1090
1091                 prodesc = (plperl_proc_desc *) SvIV(*svp);
1092
1093                 /************************************************************
1094                  * If it's present, must check whether it's still up to date.
1095                  * This is needed because CREATE OR REPLACE FUNCTION can modify the
1096                  * function's pg_proc entry without changing its OID.
1097                  ************************************************************/
1098                 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
1099                         prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
1100
1101                 if (!uptodate)
1102                 {
1103                         /* need we delete old entry? */
1104                         prodesc = NULL;
1105                 }
1106         }
1107
1108         /************************************************************
1109          * If we haven't found it in the hashtable, we analyze
1110          * the functions arguments and returntype and store
1111          * the in-/out-functions in the prodesc block and create
1112          * a new hashtable entry for it.
1113          *
1114          * Then we load the procedure into the Perl interpreter.
1115          ************************************************************/
1116         if (prodesc == NULL)
1117         {
1118                 HeapTuple       langTup;
1119                 HeapTuple       typeTup;
1120                 Form_pg_language langStruct;
1121                 Form_pg_type typeStruct;
1122                 Datum           prosrcdatum;
1123                 bool            isnull;
1124                 char       *proc_source;
1125
1126                 /************************************************************
1127                  * Allocate a new procedure description block
1128                  ************************************************************/
1129                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
1130                 if (prodesc == NULL)
1131                         ereport(ERROR,
1132                                         (errcode(ERRCODE_OUT_OF_MEMORY),
1133                                          errmsg("out of memory")));
1134                 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
1135                 prodesc->proname = strdup(internal_proname);
1136                 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
1137                 prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
1138
1139                 /* Remember if function is STABLE/IMMUTABLE */
1140                 prodesc->fn_readonly =
1141                         (procStruct->provolatile != PROVOLATILE_VOLATILE);
1142
1143                 /************************************************************
1144                  * Lookup the pg_language tuple by Oid
1145                  ************************************************************/
1146                 langTup = SearchSysCache(LANGOID,
1147                                                                  ObjectIdGetDatum(procStruct->prolang),
1148                                                                  0, 0, 0);
1149                 if (!HeapTupleIsValid(langTup))
1150                 {
1151                         free(prodesc->proname);
1152                         free(prodesc);
1153                         elog(ERROR, "cache lookup failed for language %u",
1154                                  procStruct->prolang);
1155                 }
1156                 langStruct = (Form_pg_language) GETSTRUCT(langTup);
1157                 prodesc->lanpltrusted = langStruct->lanpltrusted;
1158                 ReleaseSysCache(langTup);
1159
1160                 /************************************************************
1161                  * Get the required information for input conversion of the
1162                  * return value.
1163                  ************************************************************/
1164                 if (!is_trigger)
1165                 {
1166                         typeTup = SearchSysCache(TYPEOID,
1167                                                                 ObjectIdGetDatum(procStruct->prorettype),
1168                                                                          0, 0, 0);
1169                         if (!HeapTupleIsValid(typeTup))
1170                         {
1171                                 free(prodesc->proname);
1172                                 free(prodesc);
1173                                 elog(ERROR, "cache lookup failed for type %u",
1174                                          procStruct->prorettype);
1175                         }
1176                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1177
1178                         /* Disallow pseudotype result, except VOID or RECORD */
1179                         if (typeStruct->typtype == 'p')
1180                         {
1181                                 if (procStruct->prorettype == VOIDOID ||
1182                                         procStruct->prorettype == RECORDOID)
1183                                          /* okay */ ;
1184                                 else if (procStruct->prorettype == TRIGGEROID)
1185                                 {
1186                                         free(prodesc->proname);
1187                                         free(prodesc);
1188                                         ereport(ERROR,
1189                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1190                                                          errmsg("trigger functions may only be called "
1191                                                                         "as triggers")));
1192                                 }
1193                                 else
1194                                 {
1195                                         free(prodesc->proname);
1196                                         free(prodesc);
1197                                         ereport(ERROR,
1198                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1199                                                  errmsg("plperl functions cannot return type %s",
1200                                                                 format_type_be(procStruct->prorettype))));
1201                                 }
1202                         }
1203
1204                         prodesc->result_oid = procStruct->prorettype;
1205                         prodesc->fn_retisset = procStruct->proretset;
1206                         prodesc->fn_retistuple = (typeStruct->typtype == 'c' ||
1207                                                                           procStruct->prorettype == RECORDOID);
1208
1209                         perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1210                         prodesc->result_typioparam = getTypeIOParam(typeTup);
1211
1212                         ReleaseSysCache(typeTup);
1213                 }
1214
1215                 /************************************************************
1216                  * Get the required information for output conversion
1217                  * of all procedure arguments
1218                  ************************************************************/
1219                 if (!is_trigger)
1220                 {
1221                         prodesc->nargs = procStruct->pronargs;
1222                         for (i = 0; i < prodesc->nargs; i++)
1223                         {
1224                                 typeTup = SearchSysCache(TYPEOID,
1225                                                         ObjectIdGetDatum(procStruct->proargtypes.values[i]),
1226                                                                                  0, 0, 0);
1227                                 if (!HeapTupleIsValid(typeTup))
1228                                 {
1229                                         free(prodesc->proname);
1230                                         free(prodesc);
1231                                         elog(ERROR, "cache lookup failed for type %u",
1232                                                  procStruct->proargtypes.values[i]);
1233                                 }
1234                                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1235
1236                                 /* Disallow pseudotype argument */
1237                                 if (typeStruct->typtype == 'p')
1238                                 {
1239                                         free(prodesc->proname);
1240                                         free(prodesc);
1241                                         ereport(ERROR,
1242                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1243                                                    errmsg("plperl functions cannot take type %s",
1244                                                    format_type_be(procStruct->proargtypes.values[i]))));
1245                                 }
1246
1247                                 if (typeStruct->typtype == 'c')
1248                                         prodesc->arg_is_rowtype[i] = true;
1249                                 else
1250                                 {
1251                                         prodesc->arg_is_rowtype[i] = false;
1252                                         perm_fmgr_info(typeStruct->typoutput,
1253                                                                    &(prodesc->arg_out_func[i]));
1254                                 }
1255
1256                                 ReleaseSysCache(typeTup);
1257                         }
1258                 }
1259
1260                 /************************************************************
1261                  * create the text of the anonymous subroutine.
1262                  * we do not use a named subroutine so that we can call directly
1263                  * through the reference.
1264                  ************************************************************/
1265                 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1266                                                                           Anum_pg_proc_prosrc, &isnull);
1267                 if (isnull)
1268                         elog(ERROR, "null prosrc");
1269                 proc_source = DatumGetCString(DirectFunctionCall1(textout,
1270                                                                                                                   prosrcdatum));
1271
1272                 /************************************************************
1273                  * Create the procedure in the interpreter
1274                  ************************************************************/
1275                 prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
1276                 pfree(proc_source);
1277                 if (!prodesc->reference) /* can this happen? */
1278                 {
1279                         free(prodesc->proname);
1280                         free(prodesc);
1281                         elog(ERROR, "could not create internal procedure \"%s\"",
1282                                  internal_proname);
1283                 }
1284
1285                 hv_store(plperl_proc_hash, internal_proname, proname_len,
1286                                  newSViv((IV) prodesc), 0);
1287         }
1288
1289         ReleaseSysCache(procTup);
1290
1291         return prodesc;
1292 }
1293
1294
1295 /* Build a hash from all attributes of a given tuple. */
1296
1297 static SV  *
1298 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
1299 {
1300         HV                 *hv;
1301         int                     i;
1302
1303         hv = newHV();
1304
1305         for (i = 0; i < tupdesc->natts; i++)
1306         {
1307                 Datum           attr;
1308                 bool            isnull;
1309                 char       *attname;
1310                 char       *outputstr;
1311                 Oid                     typoutput;
1312                 bool            typisvarlena;
1313                 int                     namelen;
1314                 SV                      *sv;
1315
1316                 if (tupdesc->attrs[i]->attisdropped)
1317                         continue;
1318
1319                 attname = NameStr(tupdesc->attrs[i]->attname);
1320                 namelen = strlen(attname);
1321                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
1322
1323                 if (isnull) {
1324                         /* Store (attname => undef) and move on. */
1325                         hv_store(hv, attname, namelen, newSV(0), 0);
1326                         continue;
1327                 }
1328
1329                 /* XXX should have a way to cache these lookups */
1330
1331                 getTypeOutputInfo(tupdesc->attrs[i]->atttypid,
1332                                                   &typoutput, &typisvarlena);
1333
1334                 outputstr = DatumGetCString(OidFunctionCall1(typoutput, attr));
1335
1336                 sv = newSVpv(outputstr, 0);
1337 #if PERL_BCDVERSION >= 0x5006000L
1338                 if (GetDatabaseEncoding() == PG_UTF8)
1339                         SvUTF8_on(sv);
1340 #endif
1341                 hv_store(hv, attname, namelen, sv, 0);
1342
1343                 pfree(outputstr);
1344         }
1345
1346         return newRV_noinc((SV *) hv);
1347 }
1348
1349
1350 HV *
1351 plperl_spi_exec(char *query, int limit)
1352 {
1353         HV                 *ret_hv;
1354
1355         /*
1356          * Execute the query inside a sub-transaction, so we can cope with
1357          * errors sanely
1358          */
1359         MemoryContext oldcontext = CurrentMemoryContext;
1360         ResourceOwner oldowner = CurrentResourceOwner;
1361
1362         BeginInternalSubTransaction(NULL);
1363         /* Want to run inside function's memory context */
1364         MemoryContextSwitchTo(oldcontext);
1365
1366         PG_TRY();
1367         {
1368                 int                     spi_rv;
1369
1370                 spi_rv = SPI_execute(query, plperl_current_prodesc->fn_readonly,
1371                                                          limit);
1372                 ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
1373                                                                                                  spi_rv);
1374
1375                 /* Commit the inner transaction, return to outer xact context */
1376                 ReleaseCurrentSubTransaction();
1377                 MemoryContextSwitchTo(oldcontext);
1378                 CurrentResourceOwner = oldowner;
1379                 /*
1380                  * AtEOSubXact_SPI() should not have popped any SPI context,
1381                  * but just in case it did, make sure we remain connected.
1382                  */
1383                 SPI_restore_connection();
1384         }
1385         PG_CATCH();
1386         {
1387                 ErrorData  *edata;
1388
1389                 /* Save error info */
1390                 MemoryContextSwitchTo(oldcontext);
1391                 edata = CopyErrorData();
1392                 FlushErrorState();
1393
1394                 /* Abort the inner transaction */
1395                 RollbackAndReleaseCurrentSubTransaction();
1396                 MemoryContextSwitchTo(oldcontext);
1397                 CurrentResourceOwner = oldowner;
1398
1399                 /*
1400                  * If AtEOSubXact_SPI() popped any SPI context of the subxact,
1401                  * it will have left us in a disconnected state.  We need this
1402                  * hack to return to connected state.
1403                  */
1404                 SPI_restore_connection();
1405
1406                 /* Punt the error to Perl */
1407                 croak("%s", edata->message);
1408
1409                 /* Can't get here, but keep compiler quiet */
1410                 return NULL;
1411         }
1412         PG_END_TRY();
1413
1414         return ret_hv;
1415 }
1416
1417
1418 static HV  *
1419 plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
1420                                                                 int status)
1421 {
1422         HV                 *result;
1423
1424         result = newHV();
1425
1426         hv_store(result, "status", strlen("status"),
1427                          newSVpv((char *) SPI_result_code_string(status), 0), 0);
1428         hv_store(result, "processed", strlen("processed"),
1429                          newSViv(processed), 0);
1430
1431         if (status == SPI_OK_SELECT)
1432         {
1433                 AV                 *rows;
1434                 SV                 *row;
1435                 int                     i;
1436
1437                 rows = newAV();
1438                 for (i = 0; i < processed; i++)
1439                 {
1440                         row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
1441                         av_push(rows, row);
1442                 }
1443                 hv_store(result, "rows", strlen("rows"),
1444                                  newRV_noinc((SV *) rows), 0);
1445         }
1446
1447         SPI_freetuptable(tuptable);
1448
1449         return result;
1450 }
1451
1452
1453 void
1454 plperl_return_next(SV *sv)
1455 {
1456         plperl_proc_desc *prodesc = plperl_current_prodesc;
1457         FunctionCallInfo fcinfo = prodesc->caller_info;
1458         ReturnSetInfo *rsi = (ReturnSetInfo *)fcinfo->resultinfo;
1459         MemoryContext cxt;
1460         HeapTuple tuple;
1461         TupleDesc tupdesc;
1462
1463         if (!sv)
1464                 return;
1465
1466         if (!prodesc->fn_retisset)
1467         {
1468                 ereport(ERROR,
1469                                 (errcode(ERRCODE_SYNTAX_ERROR),
1470                                  errmsg("cannot use return_next in a non-SETOF function")));
1471         }
1472
1473         if (prodesc->fn_retistuple &&
1474                 !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
1475         {
1476                 ereport(ERROR,
1477                                 (errcode(ERRCODE_DATATYPE_MISMATCH),
1478                                  errmsg("setof-composite-returning Perl function "
1479                                                 "must call return_next with reference to hash")));
1480         }
1481
1482         cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
1483
1484         if (!prodesc->tuple_store)
1485                 prodesc->tuple_store = tuplestore_begin_heap(true, false, work_mem);
1486
1487         if (prodesc->fn_retistuple)
1488         {
1489                 TypeFuncClass rettype;
1490                 AttInMetadata *attinmeta;
1491
1492                 rettype = get_call_result_type(fcinfo, NULL, &tupdesc);
1493                 tupdesc = CreateTupleDescCopy(tupdesc);
1494                 attinmeta = TupleDescGetAttInMetadata(tupdesc);
1495                 tuple = plperl_build_tuple_result((HV *)SvRV(sv), attinmeta);
1496         }
1497         else
1498         {
1499                 Datum ret;
1500                 bool isNull;
1501
1502                 tupdesc = CreateTupleDescCopy(rsi->expectedDesc);
1503
1504                 if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
1505                 {
1506                         char *val = SvPV(sv, PL_na);
1507                         ret = FunctionCall3(&prodesc->result_in_func,
1508                                                                 PointerGetDatum(val),
1509                                                                 ObjectIdGetDatum(prodesc->result_typioparam),
1510                                                                 Int32GetDatum(-1));
1511                         isNull = false;
1512                 }
1513                 else {
1514                         ret = (Datum)0;
1515                         isNull = true;
1516                 }
1517
1518                 tuple = heap_form_tuple(tupdesc, &ret, &isNull);
1519         }
1520
1521         if (!prodesc->tuple_desc)
1522                 prodesc->tuple_desc = tupdesc;
1523
1524         tuplestore_puttuple(prodesc->tuple_store, tuple);
1525         heap_freetuple(tuple);
1526         MemoryContextSwitchTo(cxt);
1527 }