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.41 2003/11/29 19:52:12 pgsql 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 "executor/spi.h"
  49 #include "commands/trigger.h"
  50 #include "fmgr.h"
  51 #include "access/heapam.h"
  52 #include "tcop/tcopprot.h"
  53 #include "utils/syscache.h"
  54 #include "catalog/pg_language.h"
  55 #include "catalog/pg_proc.h"
  56 #include "catalog/pg_type.h"
  57
  58 /* perl stuff */
  59 #include "EXTERN.h"
  60 #include "perl.h"
  61 #include "XSUB.h"
  62 #include "ppport.h"
  63
  64 /* just in case these symbols aren't provided */
  65 #ifndef pTHX_
  66 #define pTHX_
  67 #define pTHX void
  68 #endif
  69
  70
  71 /**********************************************************************
  72  * The information we cache about loaded procedures
  73  **********************************************************************/
  74 typedef struct plperl_proc_desc
  75 {
  76         char       *proname;
  77         TransactionId fn_xmin;
  78         CommandId       fn_cmin;
  79         bool            lanpltrusted;
  80         FmgrInfo        result_in_func;
  81         Oid                     result_in_elem;
  82         int                     nargs;
  83         FmgrInfo        arg_out_func[FUNC_MAX_ARGS];
  84         Oid                     arg_out_elem[FUNC_MAX_ARGS];
  85         int                     arg_is_rel[FUNC_MAX_ARGS];
  86         SV                 *reference;
  87 }       plperl_proc_desc;
  88
  89
  90 /**********************************************************************
  91  * Global data
  92  **********************************************************************/
  93 static int      plperl_firstcall = 1;
  94 static PerlInterpreter *plperl_interp = NULL;
  95 static HV  *plperl_proc_hash = NULL;
  96
  97 /**********************************************************************
  98  * Forward declarations
  99  **********************************************************************/
 100 static void plperl_init_all(void);
 101 static void plperl_init_interp(void);
 102
 103 Datum           plperl_call_handler(PG_FUNCTION_ARGS);
 104 void            plperl_init(void);
 105
 106 static Datum plperl_func_handler(PG_FUNCTION_ARGS);
 107
 108 static plperl_proc_desc *compile_plperl_function(Oid fn_oid, bool is_trigger);
 109
 110 static SV  *plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc);
 111 static void plperl_init_shared_libs(pTHX);
 112
 113
 114 /*
 115  * This routine is a crock, and so is everyplace that calls it.  The problem
 116  * is that the cached form of plperl functions/queries is allocated permanently
 117  * (mostly via malloc()) and never released until backend exit.  Subsidiary
 118  * data structures such as fmgr info records therefore must live forever
 119  * as well.  A better implementation would store all this stuff in a per-
 120  * function memory context that could be reclaimed at need.  In the meantime,
 121  * fmgr_info_cxt must be called specifying TopMemoryContext so that whatever
 122  * it might allocate, and whatever the eventual function might allocate using
 123  * fn_mcxt, will live forever too.
 124  */
 125 static void
 126 perm_fmgr_info(Oid functionId, FmgrInfo *finfo)
 127 {
 128         fmgr_info_cxt(functionId, finfo, TopMemoryContext);
 129 }
 130
 131 /**********************************************************************
 132  * plperl_init()                        - Initialize everything that can be
 133  *                                                        safely initialized during postmaster
 134  *                                                        startup.
 135  *
 136  * DO NOT make this static --- it has to be callable by preload
 137  **********************************************************************/
 138 void
 139 plperl_init(void)
 140 {
 141         /************************************************************
 142          * Do initialization only once
 143          ************************************************************/
 144         if (!plperl_firstcall)
 145                 return;
 146
 147         /************************************************************
 148          * Free the proc hash table
 149          ************************************************************/
 150         if (plperl_proc_hash != NULL)
 151         {
 152                 hv_undef(plperl_proc_hash);
 153                 SvREFCNT_dec((SV *) plperl_proc_hash);
 154                 plperl_proc_hash = NULL;
 155         }
 156
 157         /************************************************************
 158          * Destroy the existing Perl interpreter
 159          ************************************************************/
 160         if (plperl_interp != NULL)
 161         {
 162                 perl_destruct(plperl_interp);
 163                 perl_free(plperl_interp);
 164                 plperl_interp = NULL;
 165         }
 166
 167         /************************************************************
 168          * Now recreate a new Perl interpreter
 169          ************************************************************/
 170         plperl_init_interp();
 171
 172         plperl_firstcall = 0;
 173 }
 174
 175 /**********************************************************************
 176  * plperl_init_all()            - Initialize all
 177  **********************************************************************/
 178 static void
 179 plperl_init_all(void)
 180 {
 181
 182         /************************************************************
 183          * Execute postmaster-startup safe initialization
 184          ************************************************************/
 185         if (plperl_firstcall)
 186                 plperl_init();
 187
 188         /************************************************************
 189          * Any other initialization that must be done each time a new
 190          * backend starts -- currently none
 191          ************************************************************/
 192
 193 }
 194
 195
 196 /**********************************************************************
 197  * plperl_init_interp() - Create the Perl interpreter
 198  **********************************************************************/
 199 static void
 200 plperl_init_interp(void)
 201 {
 202
 203         char       *embedding[3] = {
 204                 "", "-e",
 205
 206                 /*
 207                  * no commas between the next 5 please. They are supposed to be
 208                  * one string
 209                  */
 210                 "require Safe; SPI::bootstrap();"
 211                 "sub ::mksafefunc { my $x = new Safe; $x->permit_only(':default');$x->permit(':base_math');"
 212                 "$x->share(qw[&elog &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR]);"
 213                 " return $x->reval(qq[sub { $_[0] }]); }"
 214                 "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] } ]); }"
 215         };
 216
 217         plperl_interp = perl_alloc();
 218         if (!plperl_interp)
 219                 elog(ERROR, "could not allocate perl interpreter");
 220
 221         perl_construct(plperl_interp);
 222         perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
 223         perl_run(plperl_interp);
 224
 225         /************************************************************
 226          * Initialize the proc and query hash tables
 227          ************************************************************/
 228         plperl_proc_hash = newHV();
 229
 230 }
 231
 232
 233 /**********************************************************************
 234  * plperl_call_handler          - This is the only visible function
 235  *                                of the PL interpreter. The PostgreSQL
 236  *                                function manager and trigger manager
 237  *                                call this function for execution of
 238  *                                perl procedures.
 239  **********************************************************************/
 240 PG_FUNCTION_INFO_V1(plperl_call_handler);
 241
 242 /* keep non-static */
 243 Datum
 244 plperl_call_handler(PG_FUNCTION_ARGS)
 245 {
 246         Datum           retval;
 247
 248         /************************************************************
 249          * Initialize interpreter
 250          ************************************************************/
 251         plperl_init_all();
 252
 253         /************************************************************
 254          * Connect to SPI manager
 255          ************************************************************/
 256         if (SPI_connect() != SPI_OK_CONNECT)
 257                 elog(ERROR, "could not connect to SPI manager");
 258
 259         /************************************************************
 260          * Determine if called as function or trigger and
 261          * call appropriate subhandler
 262          ************************************************************/
 263         if (CALLED_AS_TRIGGER(fcinfo))
 264         {
 265                 ereport(ERROR,
 266                                 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 267                                  errmsg("cannot use perl in triggers yet")));
 268
 269                 /*
 270                  * retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
 271                  */
 272                 /* make the compiler happy */
 273                 retval = (Datum) 0;
 274         }
 275         else
 276                 retval = plperl_func_handler(fcinfo);
 277
 278         return retval;
 279 }
 280
 281
 282 /**********************************************************************
 283  * plperl_create_sub()          - calls the perl interpreter to
 284  *              create the anonymous subroutine whose text is in the SV.
 285  *              Returns the SV containing the RV to the closure.
 286  **********************************************************************/
 287 static SV  *
 288 plperl_create_sub(char *s, bool trusted)
 289 {
 290         dSP;
 291         SV                 *subref;
 292         int                     count;
 293
 294         ENTER;
 295         SAVETMPS;
 296         PUSHMARK(SP);
 297         XPUSHs(sv_2mortal(newSVpv(s, 0)));
 298         PUTBACK;
 299
 300         /*
 301          * G_KEEPERR seems to be needed here, else we don't recognize compile
 302          * errors properly.  Perhaps it's because there's another level of
 303          * eval inside mksafefunc?
 304          */
 305         count = perl_call_pv((trusted ? "mksafefunc" : "mkunsafefunc"),
 306                                                  G_SCALAR | G_EVAL | G_KEEPERR);
 307         SPAGAIN;
 308
 309         if (count != 1)
 310         {
 311                 PUTBACK;
 312                 FREETMPS;
 313                 LEAVE;
 314                 elog(ERROR, "didn't get a return item from mksafefunc");
 315         }
 316
 317         if (SvTRUE(ERRSV))
 318         {
 319                 POPs;
 320                 PUTBACK;
 321                 FREETMPS;
 322                 LEAVE;
 323                 elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
 324         }
 325
 326         /*
 327          * need to make a deep copy of the return. it comes off the stack as a
 328          * temporary.
 329          */
 330         subref = newSVsv(POPs);
 331
 332         if (!SvROK(subref))
 333         {
 334                 PUTBACK;
 335                 FREETMPS;
 336                 LEAVE;
 337
 338                 /*
 339                  * subref is our responsibility because it is not mortal
 340                  */
 341                 SvREFCNT_dec(subref);
 342                 elog(ERROR, "didn't get a code ref");
 343         }
 344
 345         PUTBACK;
 346         FREETMPS;
 347         LEAVE;
 348
 349         return subref;
 350 }
 351
 352 /**********************************************************************
 353  * plperl_init_shared_libs()            -
 354  *
 355  * We cannot use the DynaLoader directly to get at the Opcode
 356  * module (used by Safe.pm). So, we link Opcode into ourselves
 357  * and do the initialization behind perl's back.
 358  *
 359  **********************************************************************/
 360
 361 EXTERN_C void boot_DynaLoader(pTHX_ CV * cv);
 362 EXTERN_C void boot_SPI(pTHX_ CV * cv);
 363
 364 static void
 365 plperl_init_shared_libs(pTHX)
 366 {
 367         char       *file = __FILE__;
 368
 369         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 370         newXS("SPI::bootstrap", boot_SPI, file);
 371 }
 372
 373 /**********************************************************************
 374  * plperl_call_perl_func()              - calls a perl function through the RV
 375  *                      stored in the prodesc structure. massages the input parms properly
 376  **********************************************************************/
 377 static SV  *
 378 plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
 379 {
 380         dSP;
 381         SV                 *retval;
 382         int                     i;
 383         int                     count;
 384
 385         ENTER;
 386         SAVETMPS;
 387
 388         PUSHMARK(SP);
 389         for (i = 0; i < desc->nargs; i++)
 390         {
 391                 if (desc->arg_is_rel[i])
 392                 {
 393                         TupleTableSlot *slot = (TupleTableSlot *) fcinfo->arg[i];
 394                         SV                 *hashref;
 395
 396                         Assert(slot != NULL && !fcinfo->argnull[i]);
 397
 398                         /*
 399                          * plperl_build_tuple_argument better return a mortal SV.
 400                          */
 401                         hashref = plperl_build_tuple_argument(slot->val,
 402                                                                                           slot->ttc_tupleDescriptor);
 403                         XPUSHs(hashref);
 404                 }
 405                 else
 406                 {
 407                         if (fcinfo->argnull[i])
 408                                 XPUSHs(&PL_sv_undef);
 409                         else
 410                         {
 411                                 char       *tmp;
 412
 413                                 tmp = DatumGetCString(FunctionCall3(&(desc->arg_out_func[i]),
 414                                                                                                         fcinfo->arg[i],
 415                                                                  ObjectIdGetDatum(desc->arg_out_elem[i]),
 416                                                                                                         Int32GetDatum(-1)));
 417                                 XPUSHs(sv_2mortal(newSVpv(tmp, 0)));
 418                                 pfree(tmp);
 419                         }
 420                 }
 421         }
 422         PUTBACK;
 423
 424         /* Do NOT use G_KEEPERR here */
 425         count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
 426
 427         SPAGAIN;
 428
 429         if (count != 1)
 430         {
 431                 PUTBACK;
 432                 FREETMPS;
 433                 LEAVE;
 434                 elog(ERROR, "didn't get a return item from function");
 435         }
 436
 437         if (SvTRUE(ERRSV))
 438         {
 439                 POPs;
 440                 PUTBACK;
 441                 FREETMPS;
 442                 LEAVE;
 443                 elog(ERROR, "error from function: %s", SvPV(ERRSV, PL_na));
 444         }
 445
 446         retval = newSVsv(POPs);
 447
 448         PUTBACK;
 449         FREETMPS;
 450         LEAVE;
 451
 452         return retval;
 453 }
 454
 455
 456 /**********************************************************************
 457  * plperl_func_handler()                - Handler for regular function calls
 458  **********************************************************************/
 459 static Datum
 460 plperl_func_handler(PG_FUNCTION_ARGS)
 461 {
 462         plperl_proc_desc *prodesc;
 463         SV                 *perlret;
 464         Datum           retval;
 465
 466         /* Find or compile the function */
 467         prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false);
 468
 469         /************************************************************
 470          * Call the Perl function
 471          ************************************************************/
 472         perlret = plperl_call_perl_func(prodesc, fcinfo);
 473
 474         /************************************************************
 475          * Disconnect from SPI manager and then create the return
 476          * values datum (if the input function does a palloc for it
 477          * this must not be allocated in the SPI memory context
 478          * because SPI_finish would free it).
 479          ************************************************************/
 480         if (SPI_finish() != SPI_OK_FINISH)
 481                 elog(ERROR, "SPI_finish() failed");
 482
 483         if (!(perlret && SvOK(perlret)))
 484         {
 485                 /* return NULL if Perl code returned undef */
 486                 retval = (Datum) 0;
 487                 fcinfo->isnull = true;
 488         }
 489         else
 490         {
 491                 retval = FunctionCall3(&prodesc->result_in_func,
 492                                                            PointerGetDatum(SvPV(perlret, PL_na)),
 493                                                            ObjectIdGetDatum(prodesc->result_in_elem),
 494                                                            Int32GetDatum(-1));
 495         }
 496
 497         SvREFCNT_dec(perlret);
 498
 499         return retval;
 500 }
 501
 502
 503 /**********************************************************************
 504  * compile_plperl_function      - compile (or hopefully just look up) function
 505  **********************************************************************/
 506 static plperl_proc_desc *
 507 compile_plperl_function(Oid fn_oid, bool is_trigger)
 508 {
 509         HeapTuple       procTup;
 510         Form_pg_proc procStruct;
 511         char            internal_proname[64];
 512         int                     proname_len;
 513         plperl_proc_desc *prodesc = NULL;
 514         int                     i;
 515
 516         /* We'll need the pg_proc tuple in any case... */
 517         procTup = SearchSysCache(PROCOID,
 518                                                          ObjectIdGetDatum(fn_oid),
 519                                                          0, 0, 0);
 520         if (!HeapTupleIsValid(procTup))
 521                 elog(ERROR, "cache lookup failed for function %u", fn_oid);
 522         procStruct = (Form_pg_proc) GETSTRUCT(procTup);
 523
 524         /************************************************************
 525          * Build our internal proc name from the functions Oid
 526          ************************************************************/
 527         if (!is_trigger)
 528                 sprintf(internal_proname, "__PLPerl_proc_%u", fn_oid);
 529         else
 530                 sprintf(internal_proname, "__PLPerl_proc_%u_trigger", fn_oid);
 531         proname_len = strlen(internal_proname);
 532
 533         /************************************************************
 534          * Lookup the internal proc name in the hashtable
 535          ************************************************************/
 536         if (hv_exists(plperl_proc_hash, internal_proname, proname_len))
 537         {
 538                 bool            uptodate;
 539
 540                 prodesc = (plperl_proc_desc *) SvIV(*hv_fetch(plperl_proc_hash,
 541                                                                           internal_proname, proname_len, 0));
 542
 543                 /************************************************************
 544                  * If it's present, must check whether it's still up to date.
 545                  * This is needed because CREATE OR REPLACE FUNCTION can modify the
 546                  * function's pg_proc entry without changing its OID.
 547                  ************************************************************/
 548                 uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) &&
 549                         prodesc->fn_cmin == HeapTupleHeaderGetCmin(procTup->t_data));
 550
 551                 if (!uptodate)
 552                 {
 553                         /* need we delete old entry? */
 554                         prodesc = NULL;
 555                 }
 556         }
 557
 558         /************************************************************
 559          * If we haven't found it in the hashtable, we analyze
 560          * the functions arguments and returntype and store
 561          * the in-/out-functions in the prodesc block and create
 562          * a new hashtable entry for it.
 563          *
 564          * Then we load the procedure into the Perl interpreter.
 565          ************************************************************/
 566         if (prodesc == NULL)
 567         {
 568                 HeapTuple       langTup;
 569                 HeapTuple       typeTup;
 570                 Form_pg_language langStruct;
 571                 Form_pg_type typeStruct;
 572                 char       *proc_source;
 573
 574                 /************************************************************
 575                  * Allocate a new procedure description block
 576                  ************************************************************/
 577                 prodesc = (plperl_proc_desc *) malloc(sizeof(plperl_proc_desc));
 578                 if (prodesc == NULL)
 579                         ereport(ERROR,
 580                                         (errcode(ERRCODE_OUT_OF_MEMORY),
 581                                          errmsg("out of memory")));
 582                 MemSet(prodesc, 0, sizeof(plperl_proc_desc));
 583                 prodesc->proname = strdup(internal_proname);
 584                 prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
 585                 prodesc->fn_cmin = HeapTupleHeaderGetCmin(procTup->t_data);
 586
 587                 /************************************************************
 588                  * Lookup the pg_language tuple by Oid
 589                  ************************************************************/
 590                 langTup = SearchSysCache(LANGOID,
 591                                                                  ObjectIdGetDatum(procStruct->prolang),
 592                                                                  0, 0, 0);
 593                 if (!HeapTupleIsValid(langTup))
 594                 {
 595                         free(prodesc->proname);
 596                         free(prodesc);
 597                         elog(ERROR, "cache lookup failed for language %u",
 598                                  procStruct->prolang);
 599                 }
 600                 langStruct = (Form_pg_language) GETSTRUCT(langTup);
 601                 prodesc->lanpltrusted = langStruct->lanpltrusted;
 602                 ReleaseSysCache(langTup);
 603
 604                 /************************************************************
 605                  * Get the required information for input conversion of the
 606                  * return value.
 607                  ************************************************************/
 608                 if (!is_trigger)
 609                 {
 610                         typeTup = SearchSysCache(TYPEOID,
 611                                                                 ObjectIdGetDatum(procStruct->prorettype),
 612                                                                          0, 0, 0);
 613                         if (!HeapTupleIsValid(typeTup))
 614                         {
 615                                 free(prodesc->proname);
 616                                 free(prodesc);
 617                                 elog(ERROR, "cache lookup failed for type %u",
 618                                          procStruct->prorettype);
 619                         }
 620                         typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 621
 622                         /* Disallow pseudotype result, except VOID */
 623                         if (typeStruct->typtype == 'p')
 624                         {
 625                                 if (procStruct->prorettype == VOIDOID)
 626                                          /* okay */ ;
 627                                 else if (procStruct->prorettype == TRIGGEROID)
 628                                 {
 629                                         free(prodesc->proname);
 630                                         free(prodesc);
 631                                         ereport(ERROR,
 632                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 633                                                          errmsg("trigger functions may only be called as triggers")));
 634                                 }
 635                                 else
 636                                 {
 637                                         free(prodesc->proname);
 638                                         free(prodesc);
 639                                         ereport(ERROR,
 640                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 641                                                  errmsg("plperl functions cannot return type %s",
 642                                                                 format_type_be(procStruct->prorettype))));
 643                                 }
 644                         }
 645
 646                         if (typeStruct->typrelid != InvalidOid)
 647                         {
 648                                 free(prodesc->proname);
 649                                 free(prodesc);
 650                                 ereport(ERROR,
 651                                                 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 652                                    errmsg("plperl functions cannot return tuples yet")));
 653                         }
 654
 655                         perm_fmgr_info(typeStruct->typinput, &(prodesc->result_in_func));
 656                         prodesc->result_in_elem = typeStruct->typelem;
 657
 658                         ReleaseSysCache(typeTup);
 659                 }
 660
 661                 /************************************************************
 662                  * Get the required information for output conversion
 663                  * of all procedure arguments
 664                  ************************************************************/
 665                 if (!is_trigger)
 666                 {
 667                         prodesc->nargs = procStruct->pronargs;
 668                         for (i = 0; i < prodesc->nargs; i++)
 669                         {
 670                                 typeTup = SearchSysCache(TYPEOID,
 671                                                         ObjectIdGetDatum(procStruct->proargtypes[i]),
 672                                                                                  0, 0, 0);
 673                                 if (!HeapTupleIsValid(typeTup))
 674                                 {
 675                                         free(prodesc->proname);
 676                                         free(prodesc);
 677                                         elog(ERROR, "cache lookup failed for type %u",
 678                                                  procStruct->proargtypes[i]);
 679                                 }
 680                                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
 681
 682                                 /* Disallow pseudotype argument */
 683                                 if (typeStruct->typtype == 'p')
 684                                 {
 685                                         free(prodesc->proname);
 686                                         free(prodesc);
 687                                         ereport(ERROR,
 688                                                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
 689                                                    errmsg("plperl functions cannot take type %s",
 690                                                    format_type_be(procStruct->proargtypes[i]))));
 691                                 }
 692
 693                                 if (typeStruct->typrelid != InvalidOid)
 694                                         prodesc->arg_is_rel[i] = 1;
 695                                 else
 696                                         prodesc->arg_is_rel[i] = 0;
 697
 698                                 perm_fmgr_info(typeStruct->typoutput, &(prodesc->arg_out_func[i]));
 699                                 prodesc->arg_out_elem[i] = typeStruct->typelem;
 700                                 ReleaseSysCache(typeTup);
 701                         }
 702                 }
 703
 704                 /************************************************************
 705                  * create the text of the anonymous subroutine.
 706                  * we do not use a named subroutine so that we can call directly
 707                  * through the reference.
 708                  *
 709                  ************************************************************/
 710                 proc_source = DatumGetCString(DirectFunctionCall1(textout,
 711                                                                   PointerGetDatum(&procStruct->prosrc)));
 712
 713                 /************************************************************
 714                  * Create the procedure in the interpreter
 715                  ************************************************************/
 716                 prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
 717                 pfree(proc_source);
 718                 if (!prodesc->reference)
 719                 {
 720                         free(prodesc->proname);
 721                         free(prodesc);
 722                         elog(ERROR, "could not create internal procedure \"%s\"",
 723                                  internal_proname);
 724                 }
 725
 726                 /************************************************************
 727                  * Add the proc description block to the hashtable
 728                  ************************************************************/
 729                 hv_store(plperl_proc_hash, internal_proname, proname_len,
 730                                  newSViv((IV) prodesc), 0);
 731         }
 732
 733         ReleaseSysCache(procTup);
 734
 735         return prodesc;
 736 }
 737
 738
 739 /**********************************************************************
 740  * plperl_build_tuple_argument() - Build a string for a ref to a hash
 741  *                                from all attributes of a given tuple
 742  **********************************************************************/
 743 static SV  *
 744 plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
 745 {
 746         int                     i;
 747         SV                 *output;
 748         Datum           attr;
 749         bool            isnull;
 750         char       *attname;
 751         char       *outputstr;
 752         HeapTuple       typeTup;
 753         Oid                     typoutput;
 754         Oid                     typelem;
 755
 756         output = sv_2mortal(newSVpv("{", 0));
 757
 758         for (i = 0; i < tupdesc->natts; i++)
 759         {
 760                 /* ignore dropped attributes */
 761                 if (tupdesc->attrs[i]->attisdropped)
 762                         continue;
 763
 764                 /************************************************************
 765                  * Get the attribute name
 766                  ************************************************************/
 767                 attname = tupdesc->attrs[i]->attname.data;
 768
 769                 /************************************************************
 770                  * Get the attributes value
 771                  ************************************************************/
 772                 attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
 773
 774                 /************************************************************
 775                  *      If it is null it will be set to undef in the hash.
 776                  ************************************************************/
 777                 if (isnull)
 778                 {
 779                         sv_catpvf(output, "'%s' => undef,", attname);
 780                         continue;
 781                 }
 782
 783                 /************************************************************
 784                  * Lookup the attribute type in the syscache
 785                  * for the output function
 786                  ************************************************************/
 787                 typeTup = SearchSysCache(TYPEOID,
 788                                                    ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
 789                                                                  0, 0, 0);
 790                 if (!HeapTupleIsValid(typeTup))
 791                         elog(ERROR, "cache lookup failed for type %u",
 792                                  tupdesc->attrs[i]->atttypid);
 793
 794                 typoutput = ((Form_pg_type) GETSTRUCT(typeTup))->typoutput;
 795                 typelem = ((Form_pg_type) GETSTRUCT(typeTup))->typelem;
 796                 ReleaseSysCache(typeTup);
 797
 798                 /************************************************************
 799                  * Append the attribute name and the value to the list.
 800                  ************************************************************/
 801                 outputstr = DatumGetCString(OidFunctionCall3(typoutput,
 802                                                                                                          attr,
 803                                                                                            ObjectIdGetDatum(typelem),
 804                                                    Int32GetDatum(tupdesc->attrs[i]->atttypmod)));
 805                 sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
 806                 pfree(outputstr);
 807         }
 808
 809         sv_catpv(output, "}");
 810         output = perl_eval_pv(SvPV(output, PL_na), TRUE);
 811         return output;
 812 }