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