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 Weick.
   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.47 2004/07/21 20:45:54 momjian Exp $
  37  *
  38  **********************************************************************/
  39
  40 #include "postgres.h"
  41
  42 /* system stuff */
  43 #include <unistd.h>
  44 #include <fcntl.h>
  45 #include <setjmp.h>
  46
  47 /* postgreSQL stuff */
  48 #include "access/heapam.h"
  49 #include "catalog/pg_language.h"
  50 #include "catalog/pg_proc.h"
  51 #include "catalog/pg_type.h"
  52 #include "funcapi.h"                    /* need for SRF support */
  53 #include "commands/trigger.h"
  54 #include "executor/spi.h"
  55 #include "fmgr.h"
  56 #include "tcop/tcopprot.h"
  57 #include "utils/syscache.h"
  58 #include "utils/typcache.h"
  59
  60 /* perl stuff */
  61 #include "EXTERN.h"
  62 #include "perl.h"
  63 #include "XSUB.h"
  64 #include "ppport.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            lanpltrusted;
  82         bool            fn_retistuple;  /* true, if function returns tuple */
  83         bool            fn_retisset;            /*true, if function returns set*/
  84         Oid                     ret_oid;                /* Oid of returning type */
  85         FmgrInfo        result_in_func;
  86         Oid                     result_typioparam;
  87         int                     nargs;
  88         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  89         Oid                     arg_typioparam[FUNC_MAX_ARGS];
  90         bool            arg_is_rowtype[FUNC_MAX_ARGS];
  91         SV                 *reference;
  92 }       plperl_proc_desc;
  93
  94
  95 /**********************************************************************
  96  * Global data
  97  **********************************************************************/
  98 static int      plperl_firstcall = 1;
  99 static bool plperl_safe_init_done = false;
 100 static PerlInterpreter *plperl_interp = NULL;
 101 static HV  *plperl_proc_hash = NULL;
 102 static AV                  *g_row_keys = NULL;
 103 static AV                  *g_column_keys = NULL;
 104 static SV                  *srf_perlret=NULL; /*keep returned value*/
 105 static int                      g_attr_num = 0;
 106
 107 /**********************************************************************
 108  * Forward declarations
 109  **********************************************************************/
 110 static void plperl_init_all(void);
 111 static void plperl_init_interp(void);
 112
 113 Datum           plperl_call_handler(PG_FUNCTION_ARGS);
 114 void            plperl_init(void);
 115
 116 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 117
 118 static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
 119 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 120
 121 static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
 122 static void plperl_init_shared_libs(pTHX);
 123
 124
 125 /*
 126  * This routine is a crock, and so is everyplace that calls it.  The problem
 127  * is that the cached form of plperl functions/queries is allocated permanently
 128  * (mostly via malloc()) and never released until backend exit.  Subsidiary
 129  * data structures such as fmgr info records therefore must live forever
 130  * as well.  A better implementation would store all this stuff in a per-
 131  * function memory context that could be reclaimed at need.  In the meantime,
 132  * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
 133  * it might allocate, and whatever the eventual function might allocate using
 134  * fn_mcxt, will live forever too.
 135  */
 136 static void
 137 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
 138 {
 139         fmgr_info_cxt(functionId, finfo, TopMemoryContext);
 140 }
 141
 142 /**********************************************************************
 143  * plperl_init()                        - Initialize everything that can be
 144  *                                                        safely initialized during postmaster
 145  *                                                        startup.
 146  *
 147  * DO NOT make this static --- it has to be callable by preload
 148  **********************************************************************/
 149 void
 150 plperl_init(void)
 151 {
 152         /************************************************************
 153          * Do initialization only once
 154          ************************************************************/
 155         if (!plperl_firstcall)
 156                 return;
 157
 158         /************************************************************
 159          * Free the proc hash table
 160          ************************************************************/
 161         if (plperl_proc_hash != NULL)
 162         {
 163                 hv_undef(plperl_proc_hash);
 164                 SvREFCNT_dec((SV *) plperl_proc_hash);
 165                 plperl_proc_hash = NULL;
 166         }
 167
 168         /************************************************************
 169          * Destroy the existing Perl interpreter
 170          ************************************************************/
 171         if (plperl_interp != NULL)
 172         {
 173                 perl_destruct(plperl_interp);
 174                 perl_free(plperl_interp);
 175                 plperl_interp = NULL;
 176         }
 177
 178         /************************************************************
 179          * Now recreate a new Perl interpreter
 180          ************************************************************/
 181         plperl_init_interp();
 182
 183         plperl_firstcall = 0;
 184 }
 185
 186 /**********************************************************************
 187  * plperl_init_all()            - Initialize all
 188  **********************************************************************/
 189 static void
 190 plperl_init_all(void)
 191 {
 192
 193         /************************************************************
 194          * Execute postmaster-startup safe initialization
 195          ************************************************************/
 196         if (plperl_firstcall)
 197                 plperl_init();
 198
 199         /************************************************************
 200          * Any other initialization that must be done each time a new
 201          * backend starts -- currently none
 202          ************************************************************/
 203
 204 }
 205
 206
 207 /**********************************************************************
 208  * plperl_init_interp() - Create the Perl interpreter
 209  **********************************************************************/
 210 static void
 211 plperl_init_interp(void)
 212 {
 213
 214         char       *embedding[3] = {
 215                 "", "-e",
 216
 217                 /*
 218                  * no commas between the next lines please. They are supposed to be
 219                  * one string
 220                  */
 221                 "SPI::bootstrap(); use vars qw(%_SHARED);"
 222                 "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
 223         };
 224
 225         plperl_interp = perl_alloc();
 226         if (!plperl_interp)
 227                 elog(ERROR, "could not allocate perl interpreter");
 228
 229         perl_construct(plperl_interp);
 230         perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
 231         perl_run(plperl_interp);
 232
 233         /************************************************************
 234          * Initialize the proc and query hash tables
 235          ************************************************************/
 236         plperl_proc_hash = newHV();
 237
 238 }
 239
 240
 241 static void
 242 plperl_safe_init(void)
 243 {
 244         static char *safe_module  =
 245                 "require Safe; $Safe::VERSION";
 246
 247         static char * safe_ok =
 248                 "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
 249                 "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
 250                 "$PLContainer->share(qw[&elog &spi_exec_query &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
 251                 "sub ::mksafefunc { return $PLContainer->reval(qq[sub { $_[0] $_[1]}]); }"
 252                 ;
 253
 254         static char * safe_bad =
 255                 "use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
 256                 "$PLContainer->permit_only(':default');$PLContainer->permit(':base_math');"
 257                 "$PLContainer->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %SHARED ]);"
 258                 "sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
 259                 "elog(ERROR,'trusted perl functions disabled - please upgrade perl Safe module to at least 2.09');}]); }"
 260                 ;
 261
 262         SV * res;
 263
 264         float safe_version;
 265
 266         res = eval_pv(safe_module,FALSE); /* TRUE = croak if failure */
 267
 268         safe_version = SvNV(res);
 269
 270         eval_pv((safe_version < 2.09 ? safe_bad : safe_ok),FALSE);
 271
 272         plperl_safe_init_done = true;
 273 }
 274
 275 /**********************************************************************
 276  * turn a tuple into a hash expression and add it to a list
 277  **********************************************************************/
 278 static void
 279 plperl_sv_add_tuple_value(SV * rv, HeapTuple tuple, TupleDesc tupdesc)
 280 {
 281         int                     i;
 282         char       *value;
 283         char       *key;
 284
 285         sv_catpvf(rv, "{ ");
 286
 287         for (i = 0; i < tupdesc->natts; i++)
 288         {
 289                 key = SPI_fname(tupdesc, i + 1);
 290                 value = SPI_getvalue(tuple, tupdesc, i + 1);
 291                 if (value)
 292                         sv_catpvf(rv, "%s => '%s'", key, value);
 293                 else
 294                         sv_catpvf(rv, "%s => undef", key);
 295                 if (i != tupdesc->natts - 1)
 296                         sv_catpvf(rv, ", ");
 297         }
 298
 299         sv_catpvf(rv, " }");
 300 }
 301
 302 /**********************************************************************
 303  * set up arguments for a trigger call
 304  **********************************************************************/
 305 static SV  *
 306 plperl_trigger_build_args(FunctionCallInfo fcinfo)
 307 {
 308         TriggerData *tdata;
 309         TupleDesc       tupdesc;
 310         int                     i = 0;
 311         SV                 *rv;
 312
 313         rv = newSVpv("{ ", 0);
 314
 315         tdata = (TriggerData *) fcinfo->context;
 316
 317         tupdesc = tdata->tg_relation->rd_att;
 318
 319         sv_catpvf(rv, "name => '%s'", tdata->tg_trigger->tgname);
 320         sv_catpvf(rv, ", relid => '%s'", DatumGetCString(DirectFunctionCall1(oidout, ObjectIdGetDatum(tdata->tg_relation->rd_id))));
 321
 322         if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
 323         {
 324                 sv_catpvf(rv, ", event => 'INSERT'");
 325                 sv_catpvf(rv, ", new =>");
 326                 plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
 327         }
 328         else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
 329         {
 330                 sv_catpvf(rv, ", event => 'DELETE'");
 331                 sv_catpvf(rv, ", old => ");
 332                 plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
 333         }
 334         else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
 335         {
 336                 sv_catpvf(rv, ", event => 'UPDATE'");
 337
 338                 sv_catpvf(rv, ", new =>");
 339                 plperl_sv_add_tuple_value(rv, tdata->tg_newtuple, tupdesc);
 340
 341                 sv_catpvf(rv, ", old => ");
 342                 plperl_sv_add_tuple_value(rv, tdata->tg_trigtuple, tupdesc);
 343         }
 344         else
 345                 sv_catpvf(rv, ", event => 'UNKNOWN'");
 346
 347         sv_catpvf(rv, ", argc => %d", tdata->tg_trigger->tgnargs);
 348
 349         if (tdata->tg_trigger->tgnargs != 0)
 350         {
 351                 sv_catpvf(rv, ", args => [ ");
 352                 for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
 353                 {
 354                         sv_catpvf(rv, "%s", tdata->tg_trigger->tgargs[i]);
 355                         if (i != tdata->tg_trigger->tgnargs - 1)
 356                                 sv_catpvf(rv, ", ");
 357                 }
 358                 sv_catpvf(rv, " ]");
 359         }
 360         sv_catpvf(rv, ", relname => '%s'", SPI_getrelname(tdata->tg_relation));
 361
 362         if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
 363                 sv_catpvf(rv, ", when => 'BEFORE'");
 364         else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
 365                 sv_catpvf(rv, ", when => 'AFTER'");
 366         else
 367                 sv_catpvf(rv, ", when => 'UNKNOWN'");
 368
 369         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
 370                 sv_catpvf(rv, ", level => 'ROW'");
 371         else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
 372                 sv_catpvf(rv, ", level => 'STATEMENT'");
 373         else
 374                 sv_catpvf(rv, ", level => 'UNKNOWN'");
 375
 376         sv_catpvf(rv, " }");
 377
 378         rv = perl_eval_pv(SvPV(rv, PL_na), TRUE);
 379
 380         return rv;
 381 }
 382
 383
 384 /**********************************************************************
 385  * check return value from plperl function
 386  **********************************************************************/
 387 static int
 388 plperl_is_set(SV * sv)
 389 {
 390         int                     i = 0;
 391         int                     len = 0;
 392         int                     set = 0;
 393         int                     other = 0;
 394         AV                 *input_av;
 395         SV                **val;
 396
 397         if (SvTYPE(sv) != SVt_RV)
 398                 return 0;
 399
 400         if (SvTYPE(SvRV(sv)) == SVt_PVHV)
 401                 return 0;
 402
 403         if (SvTYPE(SvRV(sv)) == SVt_PVAV)
 404         {
 405                 input_av = (AV *) SvRV(sv);
 406                 len = av_len(input_av) + 1;
 407
 408                 for (i = 0; i < len; i++)
 409                 {
 410                         val = av_fetch(input_av, i, FALSE);
 411                         if (SvTYPE(*val) == SVt_RV)
 412                                 set = 1;
 413                         else
 414                                 other = 1;
 415                 }
 416         }
 417
 418         if (len == 0)
 419                 return 1;
 420         if (set && !other)
 421                 return 1;
 422         if (!set && other)
 423                 return 0;
 424         if (set && other)
 425                 elog(ERROR, "plperl: check your return value structure");
 426         if (!set && !other)
 427                 elog(ERROR, "plperl: check your return value structure");
 428
 429         return 0;                                       /* for compiler */
 430 }
 431
 432 /**********************************************************************
 433  * extract a list of keys from a hash
 434  **********************************************************************/
 435 static AV *
 436 plperl_get_keys(HV * hv)
 437 {
 438         AV                 *ret;
 439         SV                **svp;
 440         int                     key_count;
 441         SV                 *val;
 442         char       *key;
 443         I32                     klen;
 444
 445         key_count = 0;
 446         ret = newAV();
 447
 448         hv_iterinit(hv);
 449         while (val = hv_iternextsv(hv, (char **) &key, &klen))
 450         {
 451                 av_store(ret, key_count, eval_pv(key, TRUE));
 452                 key_count++;
 453         }
 454         hv_iterinit(hv);
 455         return ret;
 456 }
 457
 458 /**********************************************************************
 459  * extract a given key (by index) from a list of keys
 460  **********************************************************************/
 461 static char *
 462 plperl_get_key(AV * keys, int index)
 463 {
 464         SV                **svp;
 465         int                     len;
 466
 467         len = av_len(keys) + 1;
 468         if (index < len)
 469                 svp = av_fetch(keys, index, FALSE);
 470         else
 471                 return NULL;
 472         return SvPV(*svp, PL_na);
 473 }
 474
 475 /**********************************************************************
 476  * extract a value for a given key from a hash
 477  *
 478  * return NULL on error or if we got an undef
 479  *
 480  **********************************************************************/
 481 static char *
 482 plperl_get_elem(HV * hash, char *key)
 483 {
 484         SV                **svp;
 485
 486         if (hv_exists_ent(hash, eval_pv(key, TRUE), FALSE))
 487                 svp = hv_fetch(hash, key, strlen(key), FALSE);
 488         else
 489         {
 490                 elog(ERROR, "plperl: key '%s' not found", key);
 491                 return NULL;
 492         }
 493         return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na);
 494 }
 495
 496 /**********************************************************************
 497  * set up the new tuple returned from a trigger
 498  **********************************************************************/
 499 static HeapTuple
 500 plperl_modify_tuple(HV * hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
 501 {
 502         SV                **svp;
 503         HV                 *hvNew;
 504         AV                 *plkeys;
 505         char       *platt;
 506         char       *plval;
 507         HeapTuple       rtup;
 508         int                     natts,
 509                                 i,
 510                                 attn,
 511                                 atti;
 512         int                *volatile modattrs = NULL;
 513         Datum      *volatile modvalues = NULL;
 514         char       *volatile modnulls = NULL;
 515         TupleDesc       tupdesc;
 516         HeapTuple       typetup;
 517
 518         tupdesc = tdata->tg_relation->rd_att;
 519
 520         svp = hv_fetch(hvTD, "new", 3, FALSE);
 521         hvNew = (HV *) SvRV(*svp);
 522
 523         if (SvTYPE(hvNew) != SVt_PVHV)
 524                 elog(ERROR, "plperl: $_TD->{new} is not a hash");
 525
 526         plkeys = plperl_get_keys(hvNew);
 527     natts = av_len(plkeys)+1;
 528     if (natts != tupdesc->natts)
 529         elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
 530
 531         modattrs = palloc0(natts * sizeof(int));
 532         modvalues = palloc0(natts * sizeof(Datum));
 533         modnulls = palloc0(natts * sizeof(char));
 534
 535         for (i = 0; i < natts; i++)
 536         {
 537                 FmgrInfo        finfo;
 538                 Oid                     typinput;
 539                 Oid                     typelem;
 540
 541                 platt = plperl_get_key(plkeys, i);
 542
 543                 attn = modattrs[i] = SPI_fnumber(tupdesc, platt);
 544
 545                 if (attn == SPI_ERROR_NOATTRIBUTE)
 546                         elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
 547                 atti = attn - 1;
 548
 549                 plval = plperl_get_elem(hvNew, platt);
 550
 551                 typetup = SearchSysCache(TYPEOID, ObjectIdGetDatum(tupdesc->attrs[atti]->atttypid), 0, 0, 0);
 552                 typinput = ((Form_pg_type) GETSTRUCT(typetup))->typinput;
 553                 typelem = ((Form_pg_type) GETSTRUCT(typetup))->typelem;
 554                 ReleaseSysCache(typetup);
 555                 fmgr_info(typinput, &finfo);
 556
 557                 if (plval)
 558                 {
 559                         modvalues[i] = FunctionCall3(&finfo,
 560                                                                                  CStringGetDatum(plval),
 561                                                                                  ObjectIdGetDatum(typelem),
 562                                          Int32GetDatum(tupdesc->attrs[atti]->atttypmod));
 563                         modnulls[i] = ' ';
 564                 }
 565                 else
 566                 {
 567                         modvalues[i] = (Datum) 0;
 568                         modnulls[i] = 'n';
 569                 }
 570         }
 571         rtup = SPI_modifytuple(tdata->tg_relation, otup, natts, modattrs, modvalues, modnulls);
 572
 573         pfree(modattrs);
 574         pfree(modvalues);
 575         pfree(modnulls);
 576         if (rtup == NULL)
 577                 elog(ERROR, "plperl: SPI_modifytuple failed -- error:  %d", SPI_result);
 578
 579         return rtup;
 580 }
 581
 582 /**********************************************************************
 583  * plperl_call_handler          - This is the only visible function
 584  *                                of the PL interpreter. The PostgreSQL
 585  *                                function manager and trigger manager
 586  *                                call this function for execution of
 587  *                                perl procedures.
 588  **********************************************************************/
 589 PG_FUNCTION_INFO_V1(plperl_call_handler);
 590
 591 /* keep non-static */
 592 Datum
 593 plperl_call_handler(PG_FUNCTION_ARGS)
 594 {
 595         Datum           retval;
 596
 597         /************************************************************
 598          * Initialize interpreter
 599          ************************************************************/
 600         plperl_init_all();
 601
 602         /************************************************************
 603          * Connect to SPI manager
 604          ************************************************************/
 605         if (SPI_connect() != SPI_OK_CONNECT)
 606                 elog(ERROR, "could not connect to SPI manager");
 607
 608         /************************************************************
 609          * Determine if called as function or trigger and
 610          * call appropriate subhandler
 611          ************************************************************/
 612         if (CALLED_AS_TRIGGER(fcinfo))
 613                 retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
 614         else
 615                 retval = plperl_func_handler(fcinfo);
 616
 617         return retval;
 618 }
 619
 620
 621 /**********************************************************************
 622  * plperl_create_sub()          - calls the perl interpreter to
 623  *              create the anonymous subroutine whose text is in the SV.
 624  *              Returns the SV containing the RV to the closure.
 625  **********************************************************************/
 626 static SV  *
 627 plperl_create_sub(char *s, bool trusted)
 628 {
 629         dSP;
 630         SV                 *subref;
 631         int                     count;
 632
 633         if(trusted && !plperl_safe_init_done)
 634                 plperl_safe_init();
 635
 636         ENTER;
 637         SAVETMPS;
 638         PUSHMARK(SP);
 639         XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0)));
 640         XPUSHs(sv_2mortal(newSVpv(s, 0)));
 641         PUTBACK;
 642
 643         /*
 644          * G_KEEPERR seems to be needed here, else we don't recognize compile
 645          * errors properly.  Perhaps it's because there's another level of
 646          * eval inside mksafefunc?
 647          */
 648         count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
 649                                                  G_SCALAR | G_EVAL | G_KEEPERR);
 650         SPAGAIN;
 651
 652         if (count != 1)
 653         {
 654                 PUTBACK;
 655                 FREETMPS;
 656                 LEAVE;
 657                 elog(ERROR, "didn't get a return item from mksafefunc");
 658         }
 659
 660         if (SvTRUE(ERRSV))
 661         {
 662                 POPs;
 663                 PUTBACK;
 664                 FREETMPS;
 665                 LEAVE;
 666                 elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
 667         }
 668
 669         /*
 670          * need to make a deep copy of the return. it comes off the stack as a
 671          * temporary.
 672          */
 673         subref = newSVsv(POPs);
 674
 675         if (!SvROK(subref))
 676         {
 677                 PUTBACK;
 678                 FREETMPS;
 679                 LEAVE;
 680
 681                 /*
 682                  * subref is our responsibility because it is not mortal
 683                  */
 684                 SvREFCNT_dec(subref);
 685                 elog(ERROR, "didn't get a code ref");
 686         }
 687
 688         PUTBACK;
 689         FREETMPS;
 690         LEAVE;
 691
 692         return subref;
 693 }
 694
 695 /**********************************************************************
 696  * plperl_init_shared_libs()            -
 697  *
 698  * We cannot use the DynaLoader directly to get at the Opcode
 699  * module (used by Safe.pm). So, we link Opcode into ourselves
 700  * and do the initialization behind perl's back.
 701  *
 702  **********************************************************************/
 703
 704 EXTERN_C void boot_DynaLoader(pTHX_ CV * cv);
 705 EXTERN_C void boot_SPI(pTHX_ CV * cv);
 706
 707 static void
 708 plperl_init_shared_libs(pTHX)
 709 {
 710         char       *file = __FILE__;
 711
 712         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 713         newXS("SPI::bootstrap", boot_SPI, file);
 714 }
 715
 716 /**********************************************************************
 717  * plperl_call_perl_func()              - calls a perl function through the RV
 718  *                      stored in the prodesc structure. massages the input parms properly
 719  **********************************************************************/
 720 static SV  *
 721 plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
 722 {
 723         dSP;
 724         SV                 *retval;
 725         int                     i;
 726         int                     count;
 727
 728         ENTER;
 729         SAVETMPS;
 730
 731         PUSHMARK(SP);
 732         XPUSHs(sv_2mortal(newSVpv("undef", 0)));
 733         for (i = 0; i < desc->nargs; i++)
 734         {
 735                 if (desc->arg_is_rowtype[i])
 736                 {
 737                         if (fcinfo->argnull[i])
 738                                 XPUSHs(&PL_sv_undef);
 739                         else
 740                         {
 741                                 HeapTupleHeader td;
 742                                 Oid                     tupType;
 743                                 int32           tupTypmod;
 744                                 TupleDesc       tupdesc;
 745                                 HeapTupleData tmptup;
 746                                 SV                 *hashref;
 747
 748                                 td = DatumGetHeapTupleHeader(fcinfo->arg[i]);
 749                                 /* Extract rowtype info and find a tupdesc */
 750                                 tupType = HeapTupleHeaderGetTypeId(td);
 751                                 tupTypmod = HeapTupleHeaderGetTypMod(td);
 752                                 tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
 753                                 /* Build a temporary HeapTuple control structure */
 754                                 tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
 755                                 tmptup.t_data = td;
 756
 757                                 /*
 758                                  * plperl_build_tuple_argument better return a mortal SV.
 759                                  */
 760                                 hashref = plperl_build_tuple_argument(&tmptup, tupdesc);
 761                                 XPUSHs(hashref);
 762                         }
 763                 }
 764                 else
 765                 {
 766                         if (fcinfo->argnull[i])
 767                                 XPUSHs(&PL_sv_undef);
 768                         else
 769                         {
 770                                 char       *tmp;
 771
 772                                 tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
 773                                                                                                         fcinfo->arg[i],
 774                                                                  ObjectIdGetDatum(desc->arg_typioparam[i]),
 775                                                                                                         Int32GetDatum(-1)));
 776                                 XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
 777                                 pfree(tmp);
 778                         }
 779                 }
 780         }
 781         PUTBACK;
 782
 783         /* Do NOT use G_KEEPERR here */
 784         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
 785
 786         SPAGAIN;
 787
 788         if (count != 1)
 789         {
 790                 PUTBACK;
 791                 FREETMPS;
 792                 LEAVE;
 793                 elog(ERROR, "didn't get a return item from function");
 794         }
 795
 796         if (SvTRUE(ERRSV))
 797         {
 798                 POPs;
 799                 PUTBACK;
 800                 FREETMPS;
 801                 LEAVE;
 802                 elog(ERROR, "error from function: %s", SvPV(ERRSV, PL_na));
 803         }
 804
 805         retval = newSVsv(POPs);
 806
 807         PUTBACK;
 808         FREETMPS;
 809         LEAVE;
 810
 811         return retval;
 812 }
 813
 814 /**********************************************************************
 815  * plperl_call_perl_trigger_func()      - calls a perl function affected by trigger
 816  * through the RV stored in the prodesc structure. massages the input parms properly
 817  **********************************************************************/
 818 static SV  *
 819 plperl_call_perl_trigger_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo, SV * td)
 820 {
 821         dSP;
 822         SV                 *retval;
 823         int                     i;
 824         int                     count;
 825         char       *ret_test;
 826
 827         ENTER;
 828         SAVETMPS;
 829
 830         PUSHMARK(sp);
 831         XPUSHs(td);
 832         for (i = 0; i < ((TriggerData *) fcinfo->context)->tg_trigger->tgnargs; i++)
 833                 XPUSHs(sv_2mortal(newSVpv(((TriggerData *) fcinfo->context)->tg_trigger->tgargs[i], 0)));
 834         PUTBACK;
 835
 836         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL | G_KEEPERR);
 837
 838         SPAGAIN;
 839
 840         if (count != 1)
 841         {
 842                 PUTBACK;
 843                 FREETMPS;
 844                 LEAVE;
 845                 elog(ERROR, "plperl: didn't get a return item from function");
 846         }
 847
 848         if (SvTRUE(ERRSV))
 849         {
 850                 POPs;
 851                 PUTBACK;
 852                 FREETMPS;
 853                 LEAVE;
 854                 elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
 855         }
 856
 857         retval = newSVsv(POPs);
 858
 859         PUTBACK;
 860         FREETMPS;
 861         LEAVE;
 862
 863         return retval;
 864 }
 865
 866 /**********************************************************************
 867  * plperl_func_handler()                - Handler for regular function calls
 868  **********************************************************************/
 869 static Datum
 870 plperl_func_handler(PG_FUNCTION_ARGS)
 871 {
 872         plperl_proc_desc *prodesc;
 873         SV                 *perlret;
 874         Datum           retval;
 875
 876         /* Find or compile the function */
 877         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
 878         /************************************************************
 879          * Call the Perl function if not returning set
 880          ************************************************************/
 881          if (!prodesc->fn_retisset)
 882         perlret = plperl_call_perl_func(prodesc, fcinfo);
 883          else
 884         {
 885                 if (SRF_IS_FIRSTCALL()) /*call function only once*/
 886                         srf_perlret = plperl_call_perl_func(prodesc, fcinfo);
 887                 perlret = srf_perlret;
 888          }
 889
 890          if (prodesc->fn_retisset && SRF_IS_FIRSTCALL())
 891          {
 892                 if (prodesc->fn_retistuple)
 893                         g_column_keys = newAV();
 894                 if (SvTYPE(perlret) != SVt_RV)
 895                          elog(ERROR, "plperl: set-returning function must return reference");
 896         }
 897
 898         /************************************************************
 899          * Disconnect from SPI manager and then create the return
 900          * values datum (if the input function does a palloc for it
 901          * this must not be allocated in the SPI memory context
 902          * because SPI_finish would free it).
 903          ************************************************************/
 904         if (SPI_finish() != SPI_OK_FINISH)
 905                 elog(ERROR, "SPI_finish() failed");
 906
 907         if (!(perlret && SvOK(perlret) && SvTYPE(perlret)!=SVt_NULL ))
 908         {
 909                 /* return NULL if Perl code returned undef */
 910                 retval = (Datum) 0;
 911                 fcinfo->isnull = true;
 912         }
 913
 914         if (prodesc->fn_retisset && !(perlret && SvTYPE(SvRV(perlret)) == SVt_PVAV))
 915                 elog(ERROR, "plperl: set-returning function must return reference to array");
 916
 917         if (prodesc->fn_retistuple && perlret && SvTYPE(perlret) != SVt_RV)
 918                 elog(ERROR, "plperl: composite-returning function must return a reference");
 919
 920         if (prodesc->fn_retistuple && fcinfo->resultinfo ) /*  set of tuples */
 921         {
 922                 /* SRF support */
 923                 HV                 *ret_hv;
 924                 AV                 *ret_av;
 925
 926                 FuncCallContext *funcctx;
 927                 int                     call_cntr;
 928                 int                     max_calls;
 929                 TupleDesc       tupdesc;
 930                 TupleTableSlot *slot;
 931                 AttInMetadata *attinmeta;
 932                 bool            isset = 0;
 933                 char      **values = NULL;
 934                 ReturnSetInfo  *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo;
 935
 936                 if (prodesc->fn_retisset && !rsinfo)
 937                         ereport(ERROR,
 938                                         (errcode(ERRCODE_SYNTAX_ERROR),
 939                                         errmsg("returning a composite type is not allowed in this context"),
 940                                         errhint("This function is intended for use in the FROM clause.")));
 941
 942
 943                 isset = plperl_is_set(perlret);
 944
 945                 if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
 946                         ret_hv = (HV *) SvRV(perlret);
 947                 else
 948                         ret_av = (AV *) SvRV(perlret);
 949
 950                 if (SRF_IS_FIRSTCALL())
 951                 {
 952                         MemoryContext oldcontext;
 953                         int                     i;
 954
 955                         funcctx = SRF_FIRSTCALL_INIT();
 956
 957                         oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
 958
 959                         if (SvTYPE(SvRV(perlret)) == SVt_PVHV)
 960                         {
 961                                 if (isset)
 962                                         funcctx->max_calls = hv_iterinit(ret_hv);
 963                                 else
 964                                         funcctx->max_calls = 1;
 965                         }
 966                         else
 967                         {
 968                                 if (isset)
 969                                         funcctx->max_calls = av_len(ret_av) + 1;
 970                                 else
 971                                         funcctx->max_calls = 1;
 972                         }
 973
 974                         tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc);
 975
 976                         g_attr_num = tupdesc->natts;
 977
 978                         for (i = 0; i < tupdesc->natts; i++)
 979                                 av_store(g_column_keys, i + 1, eval_pv(SPI_fname(tupdesc, i + 1), TRUE));
 980
 981                         slot = TupleDescGetSlot(tupdesc);
 982                         funcctx->slot = slot;
 983                         attinmeta = TupleDescGetAttInMetadata(tupdesc);
 984                         funcctx->attinmeta = attinmeta;
 985                         MemoryContextSwitchTo(oldcontext);
 986                 }
 987
 988                 funcctx = SRF_PERCALL_SETUP();
 989                 call_cntr = funcctx->call_cntr;
 990                 max_calls = funcctx->max_calls;
 991                 slot = funcctx->slot;
 992                 attinmeta = funcctx->attinmeta;
 993
 994                 if (call_cntr < max_calls)
 995                 {
 996                         HeapTuple       tuple;
 997                         Datum           result;
 998                         int                     i;
 999                         char       *column_key;
1000                         char       *elem;
1001
1002                         if (isset)
1003                         {
1004                                 HV                 *row_hv;
1005                                 SV                **svp;
1006                                 char       *row_key;
1007
1008                                 svp = av_fetch(ret_av, call_cntr, FALSE);
1009
1010                                 row_hv = (HV *) SvRV(*svp);
1011
1012                                 values = (char **) palloc(g_attr_num * sizeof(char *));
1013
1014                                 for (i = 0; i < g_attr_num; i++)
1015                                 {
1016                                         column_key = plperl_get_key(g_column_keys, i + 1);
1017                                         elem = plperl_get_elem(row_hv, column_key);
1018                                         if (elem)
1019                                                 values[i] = elem;
1020                                         else
1021                                                 values[i] = NULL;
1022                                 }
1023                         }
1024         else
1025         {
1026                                 int                     i;
1027
1028                                 values = (char **) palloc(g_attr_num * sizeof(char *));
1029                                 for (i = 0; i < g_attr_num; i++)
1030                                 {
1031                                         column_key = SPI_fname(tupdesc, i + 1);
1032                                         elem = plperl_get_elem(ret_hv, column_key);
1033                                         if (elem)
1034                                                 values[i] = elem;
1035                                         else
1036                                                 values[i] = NULL;
1037                                 }
1038                         }
1039                         tuple = BuildTupleFromCStrings(attinmeta, values);
1040                         result = TupleGetDatum(slot, tuple);
1041                         SRF_RETURN_NEXT(funcctx, result);
1042                 }
1043                 else
1044                 {
1045                         SvREFCNT_dec(perlret);
1046                         SRF_RETURN_DONE(funcctx);
1047                 }
1048         }
1049         else if (prodesc->fn_retisset) /* set of non-tuples */
1050         {
1051                 FuncCallContext *funcctx;
1052
1053                 if (SRF_IS_FIRSTCALL())
1054                 {
1055                         MemoryContext oldcontext;
1056                         int i;
1057
1058                         funcctx = SRF_FIRSTCALL_INIT();
1059                         oldcontext = MemoryContextSwitchTo(funcctx->multi_call_memory_ctx);
1060
1061                         funcctx->max_calls = av_len((AV *) SvRV(perlret)) + 1;
1062                 }
1063
1064                 funcctx = SRF_PERCALL_SETUP();
1065
1066                 if (funcctx->call_cntr < funcctx->max_calls)
1067                 {
1068                         Datum           result;
1069                         AV*             array;
1070                         SV**            svp;
1071                         int                     i;
1072
1073                         array = (AV*)SvRV(perlret);
1074                         svp = av_fetch(array, funcctx->call_cntr, FALSE);
1075
1076                         if (SvTYPE(*svp) != SVt_NULL)
1077                                 result = FunctionCall3(&prodesc->result_in_func,
1078                                                                    PointerGetDatum(SvPV(*svp, PL_na)),
1079                                                                    ObjectIdGetDatum(prodesc->result_typioparam),
1080                                                                    Int32GetDatum(-1));
1081                         else
1082                         {
1083                                 fcinfo->isnull = true;
1084                                 result = (Datum) 0;
1085                         }
1086                         SRF_RETURN_NEXT(funcctx, result);
1087                         fcinfo->isnull = false;
1088                 }
1089                 else
1090                 {
1091                         if (perlret)
1092                                 SvREFCNT_dec(perlret);
1093                         SRF_RETURN_DONE(funcctx);
1094                 }
1095          }
1096         else if (!fcinfo->isnull) /* non-null singleton */
1097         {
1098
1099
1100                 if (prodesc->fn_retistuple) /* singleton perl hash to Datum */
1101                 {
1102                         TupleDesc td = lookup_rowtype_tupdesc(prodesc->ret_oid,(int32)-1);
1103                         HV * perlhash = (HV *) SvRV(perlret);
1104                         int i;
1105                         char **values;
1106                         char * key, *val;
1107                         AttInMetadata *attinmeta;
1108                         HeapTuple tup;
1109
1110                         if (!td)
1111                                 ereport(ERROR,
1112                                                 (errcode(ERRCODE_SYNTAX_ERROR),
1113                                                  errmsg("no TupleDesc info available")));
1114
1115                         values = (char **) palloc(td->natts * sizeof(char *));
1116                         for (i = 0; i < td->natts; i++)
1117                         {
1118
1119                                 key = SPI_fname(td,i+1);
1120                                 val = plperl_get_elem(perlhash, key);
1121                                 if (val)
1122                                         values[i] = val;
1123                                 else
1124                                         values[i] = NULL;
1125                         }
1126                         attinmeta = TupleDescGetAttInMetadata(td);
1127                         tup = BuildTupleFromCStrings(attinmeta, values);
1128                         retval = HeapTupleGetDatum(tup);
1129
1130                 }
1131                 else /* perl string to Datum */
1132
1133                 retval = FunctionCall3(&prodesc->result_in_func,
1134                                                            PointerGetDatum(SvPV(perlret, PL_na)),
1135                                                            ObjectIdGetDatum(prodesc->result_typioparam),
1136                                                            Int32GetDatum(-1));
1137
1138         }
1139
1140         SvREFCNT_dec(perlret);
1141         return retval;
1142 }
1143
1144 /**********************************************************************
1145  * plperl_trigger_handler()             - Handler for trigger function calls
1146  **********************************************************************/
1147 static Datum
1148 plperl_trigger_handler(PG_FUNCTION_ARGS)
1149 {
1150         plperl_proc_desc *prodesc;
1151         SV                 *perlret;
1152         Datum           retval;
1153         char       *tmp;
1154         SV                 *svTD;
1155         HV                 *hvTD;
1156
1157         /* Find or compile the function */
1158         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true);
1159
1160         /************************************************************
1161         * Call the Perl function
1162         ************************************************************/
1163         /*
1164         * call perl trigger function and build TD hash
1165         */
1166         svTD = plperl_trigger_build_args(fcinfo);
1167         perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
1168
1169         hvTD = (HV *) SvRV(svTD);       /* convert SV TD structure to Perl Hash
1170                                                                  * structure */
1171
1172         tmp = SvPV(perlret, PL_na);
1173
1174         /************************************************************
1175         * Disconnect from SPI manager and then create the return
1176         * values datum (if the input function does a palloc for it
1177         * this must not be allocated in the SPI memory context
1178         * because SPI_finish would free it).
1179         ************************************************************/
1180         if (SPI_finish() != SPI_OK_FINISH)
1181                 elog(ERROR, "plperl: SPI_finish() failed");
1182
1183         if (!(perlret && SvOK(perlret)))
1184         {
1185                 TriggerData *trigdata = ((TriggerData *) fcinfo->context);
1186
1187                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1188                         retval = (Datum) trigdata->tg_trigtuple;
1189                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1190                         retval = (Datum) trigdata->tg_newtuple;
1191                 else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
1192                         retval = (Datum) trigdata->tg_trigtuple;
1193         }
1194         else
1195         {
1196                 if (!fcinfo->isnull)
1197                 {
1198
1199                         HeapTuple       trv;
1200
1201                         if (strcasecmp(tmp, "SKIP") == 0)
1202                                 trv = NULL;
1203                         else if (strcasecmp(tmp, "MODIFY") == 0)
1204                         {
1205                                 TriggerData *trigdata = (TriggerData *) fcinfo->context;
1206
1207                                 if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
1208                                         trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_trigtuple, fcinfo->flinfo->fn_oid);
1209                                 else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
1210                                         trv = plperl_modify_tuple(hvTD, trigdata, trigdata->tg_newtuple, fcinfo->flinfo->fn_oid);
1211                                 else
1212                                 {
1213                                         trv = NULL;
1214                                         elog(WARNING, "plperl: Ignoring modified tuple in DELETE trigger");
1215                                 }
1216                         }
1217                         else if (strcasecmp(tmp, "OK"))
1218                         {
1219                                 trv = NULL;
1220                                 elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
1221                         }
1222                         else
1223                         {
1224                                 trv = NULL;
1225                                 elog(ERROR, "plperl: Expected return to be undef, 'SKIP' or 'MODIFY'");
1226                         }
1227                         retval = PointerGetDatum(trv);
1228                 }
1229         }
1230
1231         SvREFCNT_dec(perlret);
1232
1233         fcinfo->isnull = false;
1234         return retval;
1235 }
1236
1237 /**********************************************************************
1238  * compile_plperl_function      - compile (or hopefully just look up) function
1239  **********************************************************************/
1240 static plperl_proc_desc *
1241 compile_plperl_function(Oid fn_oid, bool is_trigger)
1242 {
1243         HeapTuple       procTup;
1244         Form_pg_proc procStruct;
1245         char            internal_proname[64];
1246         int                     proname_len;
1247         plperl_proc_desc *prodesc = NULL;
1248         int                     i;
1249
1250         /* We'll need the pg_proc tuple in any case... */
1251         procTup = SearchSysCache(PROCOID,
1252                                                          ObjectIdGetDatum(fn_oid),
1253                                                          0, 0, 0);
1254         if (!HeapTupleIsValid(procTup))
1255                 elog(ERROR, "cache lookup failed for function %u", fn_oid);
1256         procStruct = (Form_pg_proc) GETSTRUCT(procTup);
1257
1258         /************************************************************
1259          * Build our internal proc name from the functions Oid
1260          ************************************************************/
1261         if (!is_trigger)
1262                 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
1263         else
1264                 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
1265
1266         proname_len = strlen(internal_proname);
1267
1268         /************************************************************
1269          * Lookup the internal proc name in the hashtable
1270          ************************************************************/
1271         if (hv_exists(plperl_proc_hash, internal_proname, proname_len))
1272         {
1273                 bool            uptodate;
1274
1275                 prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
1276                                                                           internal_proname, proname_len, 0));
1277
1278                 /************************************************************
1279                  * If it's present, must check whether it's still up to date.
1280                  * This is needed because CREATE OR REPLACE FUNCTION can modify the
1281                  * function's pg_proc entry without changing its OID.
1282                  ************************************************************/
1283                 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
1284                         prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
1285
1286                 if (!uptodate)
1287                 {
1288                         /* need we delete old entry? */
1289                         prodesc = NULL;
1290                 }
1291         }
1292
1293         /************************************************************
1294          * If we haven't found it in the hashtable, we analyze
1295          * the functions arguments and returntype and store
1296          * the in-/out-functions in the prodesc block and create
1297          * a new hashtable entry for it.
1298          *
1299          * Then we load the procedure into the Perl interpreter.
1300          ************************************************************/
1301         if (prodesc == NULL)
1302         {
1303                 HeapTuple       langTup;
1304                 HeapTuple       typeTup;
1305                 Form_pg_language langStruct;
1306                 Form_pg_type typeStruct;
1307                 Datum           prosrcdatum;
1308                 bool            isnull;
1309                 char       *proc_source;
1310
1311                 /************************************************************
1312                  * Allocate a new procedure description block
1313                  ************************************************************/
1314                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
1315                 if (prodesc == NULL)
1316                         ereport(ERROR,
1317                                         (errcode(ERRCODE_OUT_OF_MEMORY),
1318                                          errmsg("out of memory")));
1319                 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
1320                 prodesc->proname = strdup(internal_proname);
1321                 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
1322                 prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
1323
1324                 /************************************************************
1325                  * Lookup the pg_language tuple by Oid
1326                  ************************************************************/
1327                 langTup = SearchSysCache(LANGOID,
1328                                                                  ObjectIdGetDatum(procStruct->prolang),
1329                                                                  0, 0, 0);
1330                 if (!HeapTupleIsValid(langTup))
1331                 {
1332                         free(prodesc->proname);
1333                         free(prodesc);
1334                         elog(ERROR, "cache lookup failed for language %u",
1335                                  procStruct->prolang);
1336                 }
1337                 langStruct = (Form_pg_language) GETSTRUCT(langTup);
1338                 prodesc->lanpltrusted = langStruct->lanpltrusted;
1339                 ReleaseSysCache(langTup);
1340
1341                 /************************************************************
1342                  * Get the required information for input conversion of the
1343                  * return value.
1344                  ************************************************************/
1345                 if (!is_trigger)
1346                 {
1347                         typeTup = SearchSysCache(TYPEOID,
1348                                                                 ObjectIdGetDatum(procStruct->prorettype),
1349                                                                          0, 0, 0);
1350                         if (!HeapTupleIsValid(typeTup))
1351                         {
1352                                 free(prodesc->proname);
1353                                 free(prodesc);
1354                                 elog(ERROR, "cache lookup failed for type %u",
1355                                          procStruct->prorettype);
1356                         }
1357                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1358
1359                         /* Disallow pseudotype result, except VOID or RECORD */
1360                         if (typeStruct->typtype == 'p')
1361                         {
1362                                 if (procStruct->prorettype == VOIDOID ||
1363                                         procStruct->prorettype == RECORDOID)
1364                                          /* okay */ ;
1365                                 else if (procStruct->prorettype == TRIGGEROID)
1366                                 {
1367                                         free(prodesc->proname);
1368                                         free(prodesc);
1369                                         ereport(ERROR,
1370                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1371                                                          errmsg("trigger functions may only be called as triggers")));
1372                                 }
1373                                 else
1374                                 {
1375                                         free(prodesc->proname);
1376                                         free(prodesc);
1377                                         ereport(ERROR,
1378                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1379                                                  errmsg("plperl functions cannot return type %s",
1380                                                                 format_type_be(procStruct->prorettype))));
1381                                 }
1382                         }
1383
1384                         prodesc->fn_retisset = procStruct->proretset;           /* true, if function
1385                                                                                                                                  * returns set */
1386
1387                         if (typeStruct->typtype == 'c' || procStruct->prorettype == RECORDOID)
1388                         {
1389                                 prodesc->fn_retistuple = true;
1390                                 prodesc->ret_oid =
1391                                         procStruct->prorettype == RECORDOID ?
1392                                         typeStruct->typrelid :
1393                                         procStruct->prorettype;
1394                         }
1395
1396                         perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
1397                         prodesc->result_typioparam = getTypeIOParam(typeTup);
1398
1399                         ReleaseSysCache(typeTup);
1400                 }
1401
1402                 /************************************************************
1403                  * Get the required information for output conversion
1404                  * of all procedure arguments
1405                  ************************************************************/
1406                 if (!is_trigger)
1407                 {
1408                         prodesc->nargs = procStruct->pronargs;
1409                         for (i = 0; i < prodesc->nargs; i++)
1410                         {
1411                                 typeTup = SearchSysCache(TYPEOID,
1412                                                         ObjectIdGetDatum(procStruct->proargtypes[i]),
1413                                                                                  0, 0, 0);
1414                                 if (!HeapTupleIsValid(typeTup))
1415                                 {
1416                                         free(prodesc->proname);
1417                                         free(prodesc);
1418                                         elog(ERROR, "cache lookup failed for type %u",
1419                                                  procStruct->proargtypes[i]);
1420                                 }
1421                                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
1422
1423                                 /* Disallow pseudotype argument */
1424                                 if (typeStruct->typtype == 'p')
1425                                 {
1426                                         free(prodesc->proname);
1427                                         free(prodesc);
1428                                         ereport(ERROR,
1429                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1430                                                    errmsg("plperl functions cannot take type %s",
1431                                                    format_type_be(procStruct->proargtypes[i]))));
1432                                 }
1433
1434                                 if (typeStruct->typtype == 'c')
1435                                         prodesc->arg_is_rowtype[i] = true;
1436                                 else
1437                                 {
1438                                         prodesc->arg_is_rowtype[i] = false;
1439                                         perm_fmgr_info(typeStruct->typoutput,
1440                                                                    &(prodesc->arg_out_func[i]));
1441                                         prodesc->arg_typioparam[i] = getTypeIOParam(typeTup);
1442                                 }
1443
1444                                 ReleaseSysCache(typeTup);
1445                         }
1446                 }
1447
1448                 /************************************************************
1449                  * create the text of the anonymous subroutine.
1450                  * we do not use a named subroutine so that we can call directly
1451                  * through the reference.
1452                  *
1453                  ************************************************************/
1454                 prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
1455                                                                           Anum_pg_proc_prosrc, &isnull);
1456                 if (isnull)
1457                         elog(ERROR, "null prosrc");
1458                 proc_source = DatumGetCString(DirectFunctionCall1(textout,
1459                                                                                                                   prosrcdatum));
1460
1461                 /************************************************************
1462                  * Create the procedure in the interpreter
1463                  ************************************************************/
1464                 prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
1465                 pfree(proc_source);
1466                 if (!prodesc->reference)
1467                 {
1468                         free(prodesc->proname);
1469                         free(prodesc);
1470                         elog(ERROR, "could not create internal procedure \"%s\"",
1471                                  internal_proname);
1472                 }
1473
1474                 /************************************************************
1475                  * Add the proc description block to the hashtable
1476                  ************************************************************/
1477                 hv_store(plperl_proc_hash, internal_proname, proname_len,
1478                                  newSViv((IV) prodesc), 0);
1479         }
1480
1481         ReleaseSysCache(procTup);
1482
1483         return prodesc;
1484 }
1485
1486
1487 /**********************************************************************
1488  * plperl_build_tuple_argument() - Build a string for a ref to a hash
1489  *                                from all attributes of a given tuple
1490  **********************************************************************/
1491 static SV  *
1492 plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
1493 {
1494         int                     i;
1495         SV                 *output;
1496         Datum           attr;
1497         bool            isnull;
1498         char       *attname;
1499         char       *outputstr;
1500         HeapTuple       typeTup;
1501         Oid                     typoutput;
1502         Oid                     typioparam;
1503
1504         output = sv_2mortal(newSVpv("{", 0));
1505
1506         for (i = 0; i < tupdesc->natts; i++)
1507         {
1508                 /* ignore dropped attributes */
1509                 if (tupdesc->attrs[i]->attisdropped)
1510                         continue;
1511
1512                 /************************************************************
1513                  * Get the attribute name
1514                  ************************************************************/
1515                 attname = tupdesc->attrs[i]->attname.data;
1516
1517                 /************************************************************
1518                  * Get the attributes value
1519                  ************************************************************/
1520                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
1521
1522                 /************************************************************
1523                  *      If it is null it will be set to undef in the hash.
1524                  ************************************************************/
1525                 if (isnull)
1526                 {
1527                         sv_catpvf(output, "'%s' => undef,", attname);
1528                         continue;
1529                 }
1530
1531                 /************************************************************
1532                  * Lookup the attribute type in the syscache
1533                  * for the output function
1534                  ************************************************************/
1535                 typeTup = SearchSysCache(TYPEOID,
1536                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
1537                                                                  0, 0, 0);
1538                 if (!HeapTupleIsValid(typeTup))
1539                         elog(ERROR, "cache lookup failed for type %u",
1540                                  tupdesc->attrs[i]->atttypid);
1541
1542                 typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
1543                 typioparam = getTypeIOParam(typeTup);
1544                 ReleaseSysCache(typeTup);
1545
1546                 /************************************************************
1547                  * Append the attribute name and the value to the list.
1548                  ************************************************************/
1549                 outputstr = DatumGetCString(OidFunctionCall3(typoutput,
1550                                                                                                          attr,
1551                                                                                            ObjectIdGetDatum(typioparam),
1552                                                    Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
1553                 sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
1554                 pfree(outputstr);
1555         }
1556
1557         sv_catpv(output, "}");
1558         output = perl_eval_pv(SvPV(output, PL_na), TRUE);
1559         return output;
1560 }