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