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