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