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