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