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