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