LCOV - code coverage report
Current view: top level - src/pl/plperl - plperl.c (source / functions) Hit Total Coverage
Test: PostgreSQL 15devel Lines: 1266 1428 88.7 %
Date: 2021-12-05 02:08:31 Functions: 73 73 100.0 %
Legend: Lines: hit not hit

          Line data    Source code
       1             : /**********************************************************************
       2             :  * plperl.c - perl as a procedural language for PostgreSQL
       3             :  *
       4             :  *    src/pl/plperl/plperl.c
       5             :  *
       6             :  **********************************************************************/
       7             : 
       8             : #include "postgres.h"
       9             : 
      10             : /* system stuff */
      11             : #include <ctype.h>
      12             : #include <fcntl.h>
      13             : #include <limits.h>
      14             : #include <unistd.h>
      15             : 
      16             : /* postgreSQL stuff */
      17             : #include "access/htup_details.h"
      18             : #include "access/xact.h"
      19             : #include "catalog/pg_language.h"
      20             : #include "catalog/pg_proc.h"
      21             : #include "catalog/pg_type.h"
      22             : #include "commands/event_trigger.h"
      23             : #include "commands/trigger.h"
      24             : #include "executor/spi.h"
      25             : #include "funcapi.h"
      26             : #include "mb/pg_wchar.h"
      27             : #include "miscadmin.h"
      28             : #include "nodes/makefuncs.h"
      29             : #include "parser/parse_type.h"
      30             : #include "storage/ipc.h"
      31             : #include "tcop/tcopprot.h"
      32             : #include "utils/builtins.h"
      33             : #include "utils/fmgroids.h"
      34             : #include "utils/guc.h"
      35             : #include "utils/hsearch.h"
      36             : #include "utils/lsyscache.h"
      37             : #include "utils/memutils.h"
      38             : #include "utils/rel.h"
      39             : #include "utils/syscache.h"
      40             : #include "utils/typcache.h"
      41             : 
      42             : /* define our text domain for translations */
      43             : #undef TEXTDOMAIN
      44             : #define TEXTDOMAIN PG_TEXTDOMAIN("plperl")
      45             : 
      46             : /* perl stuff */
      47             : /* string literal macros defining chunks of perl code */
      48             : #include "perlchunks.h"
      49             : #include "plperl.h"
      50             : #include "plperl_helpers.h"
      51             : /* defines PLPERL_SET_OPMASK */
      52             : #include "plperl_opmask.h"
      53             : 
      54             : EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
      55             : EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
      56             : EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
      57             : 
      58          42 : PG_MODULE_MAGIC;
      59             : 
      60             : /**********************************************************************
      61             :  * Information associated with a Perl interpreter.  We have one interpreter
      62             :  * that is used for all plperlu (untrusted) functions.  For plperl (trusted)
      63             :  * functions, there is a separate interpreter for each effective SQL userid.
      64             :  * (This is needed to ensure that an unprivileged user can't inject Perl code
      65             :  * that'll be executed with the privileges of some other SQL user.)
      66             :  *
      67             :  * The plperl_interp_desc structs are kept in a Postgres hash table indexed
      68             :  * by userid OID, with OID 0 used for the single untrusted interpreter.
      69             :  * Once created, an interpreter is kept for the life of the process.
      70             :  *
      71             :  * We start out by creating a "held" interpreter, which we initialize
      72             :  * only as far as we can do without deciding if it will be trusted or
      73             :  * untrusted.  Later, when we first need to run a plperl or plperlu
      74             :  * function, we complete the initialization appropriately and move the
      75             :  * PerlInterpreter pointer into the plperl_interp_hash hashtable.  If after
      76             :  * that we need more interpreters, we create them as needed if we can, or
      77             :  * fail if the Perl build doesn't support multiple interpreters.
      78             :  *
      79             :  * The reason for all the dancing about with a held interpreter is to make
      80             :  * it possible for people to preload a lot of Perl code at postmaster startup
      81             :  * (using plperl.on_init) and then use that code in backends.  Of course this
      82             :  * will only work for the first interpreter created in any backend, but it's
      83             :  * still useful with that restriction.
      84             :  **********************************************************************/
      85             : typedef struct plperl_interp_desc
      86             : {
      87             :     Oid         user_id;        /* Hash key (must be first!) */
      88             :     PerlInterpreter *interp;    /* The interpreter */
      89             :     HTAB       *query_hash;     /* plperl_query_entry structs */
      90             : } plperl_interp_desc;
      91             : 
      92             : 
      93             : /**********************************************************************
      94             :  * The information we cache about loaded procedures
      95             :  *
      96             :  * The fn_refcount field counts the struct's reference from the hash table
      97             :  * shown below, plus one reference for each function call level that is using
      98             :  * the struct.  We can release the struct, and the associated Perl sub, when
      99             :  * the fn_refcount goes to zero.  Releasing the struct itself is done by
     100             :  * deleting the fn_cxt, which also gets rid of all subsidiary data.
     101             :  **********************************************************************/
     102             : typedef struct plperl_proc_desc
     103             : {
     104             :     char       *proname;        /* user name of procedure */
     105             :     MemoryContext fn_cxt;       /* memory context for this procedure */
     106             :     unsigned long fn_refcount;  /* number of active references */
     107             :     TransactionId fn_xmin;      /* xmin/TID of procedure's pg_proc tuple */
     108             :     ItemPointerData fn_tid;
     109             :     SV         *reference;      /* CODE reference for Perl sub */
     110             :     plperl_interp_desc *interp; /* interpreter it's created in */
     111             :     bool        fn_readonly;    /* is function readonly (not volatile)? */
     112             :     Oid         lang_oid;
     113             :     List       *trftypes;
     114             :     bool        lanpltrusted;   /* is it plperl, rather than plperlu? */
     115             :     bool        fn_retistuple;  /* true, if function returns tuple */
     116             :     bool        fn_retisset;    /* true, if function returns set */
     117             :     bool        fn_retisarray;  /* true if function returns array */
     118             :     /* Conversion info for function's result type: */
     119             :     Oid         result_oid;     /* Oid of result type */
     120             :     FmgrInfo    result_in_func; /* I/O function and arg for result type */
     121             :     Oid         result_typioparam;
     122             :     /* Per-argument info for function's argument types: */
     123             :     int         nargs;
     124             :     FmgrInfo   *arg_out_func;   /* output fns for arg types */
     125             :     bool       *arg_is_rowtype; /* is each arg composite? */
     126             :     Oid        *arg_arraytype;  /* InvalidOid if not an array */
     127             : } plperl_proc_desc;
     128             : 
     129             : #define increment_prodesc_refcount(prodesc)  \
     130             :     ((prodesc)->fn_refcount++)
     131             : #define decrement_prodesc_refcount(prodesc)  \
     132             :     do { \
     133             :         Assert((prodesc)->fn_refcount > 0); \
     134             :         if (--((prodesc)->fn_refcount) == 0) \
     135             :             free_plperl_function(prodesc); \
     136             :     } while(0)
     137             : 
     138             : /**********************************************************************
     139             :  * For speedy lookup, we maintain a hash table mapping from
     140             :  * function OID + trigger flag + user OID to plperl_proc_desc pointers.
     141             :  * The reason the plperl_proc_desc struct isn't directly part of the hash
     142             :  * entry is to simplify recovery from errors during compile_plperl_function.
     143             :  *
     144             :  * Note: if the same function is called by multiple userIDs within a session,
     145             :  * there will be a separate plperl_proc_desc entry for each userID in the case
     146             :  * of plperl functions, but only one entry for plperlu functions, because we
     147             :  * set user_id = 0 for that case.  If the user redeclares the same function
     148             :  * from plperl to plperlu or vice versa, there might be multiple
     149             :  * plperl_proc_ptr entries in the hashtable, but only one is valid.
     150             :  **********************************************************************/
     151             : typedef struct plperl_proc_key
     152             : {
     153             :     Oid         proc_id;        /* Function OID */
     154             : 
     155             :     /*
     156             :      * is_trigger is really a bool, but declare as Oid to ensure this struct
     157             :      * contains no padding
     158             :      */
     159             :     Oid         is_trigger;     /* is it a trigger function? */
     160             :     Oid         user_id;        /* User calling the function, or 0 */
     161             : } plperl_proc_key;
     162             : 
     163             : typedef struct plperl_proc_ptr
     164             : {
     165             :     plperl_proc_key proc_key;   /* Hash key (must be first!) */
     166             :     plperl_proc_desc *proc_ptr;
     167             : } plperl_proc_ptr;
     168             : 
     169             : /*
     170             :  * The information we cache for the duration of a single call to a
     171             :  * function.
     172             :  */
     173             : typedef struct plperl_call_data
     174             : {
     175             :     plperl_proc_desc *prodesc;
     176             :     FunctionCallInfo fcinfo;
     177             :     /* remaining fields are used only in a function returning set: */
     178             :     Tuplestorestate *tuple_store;
     179             :     TupleDesc   ret_tdesc;
     180             :     Oid         cdomain_oid;    /* 0 unless returning domain-over-composite */
     181             :     void       *cdomain_info;
     182             :     MemoryContext tmp_cxt;
     183             : } plperl_call_data;
     184             : 
     185             : /**********************************************************************
     186             :  * The information we cache about prepared and saved plans
     187             :  **********************************************************************/
     188             : typedef struct plperl_query_desc
     189             : {
     190             :     char        qname[24];
     191             :     MemoryContext plan_cxt;     /* context holding this struct */
     192             :     SPIPlanPtr  plan;
     193             :     int         nargs;
     194             :     Oid        *argtypes;
     195             :     FmgrInfo   *arginfuncs;
     196             :     Oid        *argtypioparams;
     197             : } plperl_query_desc;
     198             : 
     199             : /* hash table entry for query desc  */
     200             : 
     201             : typedef struct plperl_query_entry
     202             : {
     203             :     char        query_name[NAMEDATALEN];
     204             :     plperl_query_desc *query_data;
     205             : } plperl_query_entry;
     206             : 
     207             : /**********************************************************************
     208             :  * Information for PostgreSQL - Perl array conversion.
     209             :  **********************************************************************/
     210             : typedef struct plperl_array_info
     211             : {
     212             :     int         ndims;
     213             :     bool        elem_is_rowtype;    /* 't' if element type is a rowtype */
     214             :     Datum      *elements;
     215             :     bool       *nulls;
     216             :     int        *nelems;
     217             :     FmgrInfo    proc;
     218             :     FmgrInfo    transform_proc;
     219             : } plperl_array_info;
     220             : 
     221             : /**********************************************************************
     222             :  * Global data
     223             :  **********************************************************************/
     224             : 
     225             : static HTAB *plperl_interp_hash = NULL;
     226             : static HTAB *plperl_proc_hash = NULL;
     227             : static plperl_interp_desc *plperl_active_interp = NULL;
     228             : 
     229             : /* If we have an unassigned "held" interpreter, it's stored here */
     230             : static PerlInterpreter *plperl_held_interp = NULL;
     231             : 
     232             : /* GUC variables */
     233             : static bool plperl_use_strict = false;
     234             : static char *plperl_on_init = NULL;
     235             : static char *plperl_on_plperl_init = NULL;
     236             : static char *plperl_on_plperlu_init = NULL;
     237             : 
     238             : static bool plperl_ending = false;
     239             : static OP  *(*pp_require_orig) (pTHX) = NULL;
     240             : static char plperl_opmask[MAXO];
     241             : 
     242             : /* this is saved and restored by plperl_call_handler */
     243             : static plperl_call_data *current_call_data = NULL;
     244             : 
     245             : /**********************************************************************
     246             :  * Forward declarations
     247             :  **********************************************************************/
     248             : void        _PG_init(void);
     249             : 
     250             : static PerlInterpreter *plperl_init_interp(void);
     251             : static void plperl_destroy_interp(PerlInterpreter **);
     252             : static void plperl_fini(int code, Datum arg);
     253             : static void set_interp_require(bool trusted);
     254             : 
     255             : static Datum plperl_func_handler(PG_FUNCTION_ARGS);
     256             : static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
     257             : static void plperl_event_trigger_handler(PG_FUNCTION_ARGS);
     258             : 
     259             : static void free_plperl_function(plperl_proc_desc *prodesc);
     260             : 
     261             : static plperl_proc_desc *compile_plperl_function(Oid fn_oid,
     262             :                                                  bool is_trigger,
     263             :                                                  bool is_event_trigger);
     264             : 
     265             : static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc, bool include_generated);
     266             : static SV  *plperl_hash_from_datum(Datum attr);
     267             : static SV  *plperl_ref_from_pg_array(Datum arg, Oid typid);
     268             : static SV  *split_array(plperl_array_info *info, int first, int last, int nest);
     269             : static SV  *make_array_ref(plperl_array_info *info, int first, int last);
     270             : static SV  *get_perl_array_ref(SV *sv);
     271             : static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
     272             :                                 FunctionCallInfo fcinfo,
     273             :                                 FmgrInfo *finfo, Oid typioparam,
     274             :                                 bool *isnull);
     275             : static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam);
     276             : static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod);
     277             : static void array_to_datum_internal(AV *av, ArrayBuildState *astate,
     278             :                                     int *ndims, int *dims, int cur_depth,
     279             :                                     Oid arraytypid, Oid elemtypid, int32 typmod,
     280             :                                     FmgrInfo *finfo, Oid typioparam);
     281             : static Datum plperl_hash_to_datum(SV *src, TupleDesc td);
     282             : 
     283             : static void plperl_init_shared_libs(pTHX);
     284             : static void plperl_trusted_init(void);
     285             : static void plperl_untrusted_init(void);
     286             : static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int);
     287             : static void plperl_return_next_internal(SV *sv);
     288             : static char *hek2cstr(HE *he);
     289             : static SV **hv_store_string(HV *hv, const char *key, SV *val);
     290             : static SV **hv_fetch_string(HV *hv, const char *key);
     291             : static void plperl_create_sub(plperl_proc_desc *desc, const char *s, Oid fn_oid);
     292             : static SV  *plperl_call_perl_func(plperl_proc_desc *desc,
     293             :                                   FunctionCallInfo fcinfo);
     294             : static void plperl_compile_callback(void *arg);
     295             : static void plperl_exec_callback(void *arg);
     296             : static void plperl_inline_callback(void *arg);
     297             : static char *strip_trailing_ws(const char *msg);
     298             : static OP  *pp_require_safe(pTHX);
     299             : static void activate_interpreter(plperl_interp_desc *interp_desc);
     300             : 
     301             : #ifdef WIN32
     302             : static char *setlocale_perl(int category, char *locale);
     303             : #endif
     304             : 
     305             : /*
     306             :  * Decrement the refcount of the given SV within the active Perl interpreter
     307             :  *
     308             :  * This is handy because it reloads the active-interpreter pointer, saving
     309             :  * some notation in callers that switch the active interpreter.
     310             :  */
     311             : static inline void
     312         604 : SvREFCNT_dec_current(SV *sv)
     313             : {
     314         604 :     dTHX;
     315             : 
     316         604 :     SvREFCNT_dec(sv);
     317         604 : }
     318             : 
     319             : /*
     320             :  * convert a HE (hash entry) key to a cstr in the current database encoding
     321             :  */
     322             : static char *
     323         406 : hek2cstr(HE *he)
     324             : {
     325         406 :     dTHX;
     326             :     char       *ret;
     327             :     SV         *sv;
     328             : 
     329             :     /*
     330             :      * HeSVKEY_force will return a temporary mortal SV*, so we need to make
     331             :      * sure to free it with ENTER/SAVE/FREE/LEAVE
     332             :      */
     333         406 :     ENTER;
     334         406 :     SAVETMPS;
     335             : 
     336             :     /*-------------------------
     337             :      * Unfortunately,  while HeUTF8 is true for most things > 256, for values
     338             :      * 128..255 it's not, but perl will treat them as unicode code points if
     339             :      * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
     340             :      * for more)
     341             :      *
     342             :      * So if we did the expected:
     343             :      *    if (HeUTF8(he))
     344             :      *        utf_u2e(key...);
     345             :      *    else // must be ascii
     346             :      *        return HePV(he);
     347             :      * we won't match columns with codepoints from 128..255
     348             :      *
     349             :      * For a more concrete example given a column with the name of the unicode
     350             :      * codepoint U+00ae (registered sign) and a UTF8 database and the perl
     351             :      * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
     352             :      * 0 and HePV() would give us a char * with 1 byte contains the decimal
     353             :      * value 174
     354             :      *
     355             :      * Perl has the brains to know when it should utf8 encode 174 properly, so
     356             :      * here we force it into an SV so that perl will figure it out and do the
     357             :      * right thing
     358             :      *-------------------------
     359             :      */
     360             : 
     361         406 :     sv = HeSVKEY_force(he);
     362         406 :     if (HeUTF8(he))
     363           0 :         SvUTF8_on(sv);
     364         406 :     ret = sv2cstr(sv);
     365             : 
     366             :     /* free sv */
     367         406 :     FREETMPS;
     368         406 :     LEAVE;
     369             : 
     370         406 :     return ret;
     371             : }
     372             : 
     373             : 
     374             : /*
     375             :  * _PG_init()           - library load-time initialization
     376             :  *
     377             :  * DO NOT make this static nor change its name!
     378             :  */
     379             : void
     380          42 : _PG_init(void)
     381             : {
     382             :     /*
     383             :      * Be sure we do initialization only once.
     384             :      *
     385             :      * If initialization fails due to, e.g., plperl_init_interp() throwing an
     386             :      * exception, then we'll return here on the next usage and the user will
     387             :      * get a rather cryptic: ERROR:  attempt to redefine parameter
     388             :      * "plperl.use_strict"
     389             :      */
     390             :     static bool inited = false;
     391             :     HASHCTL     hash_ctl;
     392             : 
     393          42 :     if (inited)
     394           0 :         return;
     395             : 
     396             :     /*
     397             :      * Support localized messages.
     398             :      */
     399          42 :     pg_bindtextdomain(TEXTDOMAIN);
     400             : 
     401             :     /*
     402             :      * Initialize plperl's GUCs.
     403             :      */
     404          42 :     DefineCustomBoolVariable("plperl.use_strict",
     405             :                              gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
     406             :                              NULL,
     407             :                              &plperl_use_strict,
     408             :                              false,
     409             :                              PGC_USERSET, 0,
     410             :                              NULL, NULL, NULL);
     411             : 
     412             :     /*
     413             :      * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
     414             :      * be executed in the postmaster (if plperl is loaded into the postmaster
     415             :      * via shared_preload_libraries).  This isn't really right either way,
     416             :      * though.
     417             :      */
     418          42 :     DefineCustomStringVariable("plperl.on_init",
     419             :                                gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
     420             :                                NULL,
     421             :                                &plperl_on_init,
     422             :                                NULL,
     423             :                                PGC_SIGHUP, 0,
     424             :                                NULL, NULL, NULL);
     425             : 
     426             :     /*
     427             :      * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
     428             :      * user who might not even have USAGE privilege on the plperl language
     429             :      * could nonetheless use SET plperl.on_plperl_init='...' to influence the
     430             :      * behaviour of any existing plperl function that they can execute (which
     431             :      * might be SECURITY DEFINER, leading to a privilege escalation).  See
     432             :      * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
     433             :      * the overall thread.
     434             :      *
     435             :      * Note that because plperl.use_strict is USERSET, a nefarious user could
     436             :      * set it to be applied against other people's functions.  This is judged
     437             :      * OK since the worst result would be an error.  Your code oughta pass
     438             :      * use_strict anyway ;-)
     439             :      */
     440          42 :     DefineCustomStringVariable("plperl.on_plperl_init",
     441             :                                gettext_noop("Perl initialization code to execute once when plperl is first used."),
     442             :                                NULL,
     443             :                                &plperl_on_plperl_init,
     444             :                                NULL,
     445             :                                PGC_SUSET, 0,
     446             :                                NULL, NULL, NULL);
     447             : 
     448          42 :     DefineCustomStringVariable("plperl.on_plperlu_init",
     449             :                                gettext_noop("Perl initialization code to execute once when plperlu is first used."),
     450             :                                NULL,
     451             :                                &plperl_on_plperlu_init,
     452             :                                NULL,
     453             :                                PGC_SUSET, 0,
     454             :                                NULL, NULL, NULL);
     455             : 
     456          42 :     EmitWarningsOnPlaceholders("plperl");
     457             : 
     458             :     /*
     459             :      * Create hash tables.
     460             :      */
     461          42 :     hash_ctl.keysize = sizeof(Oid);
     462          42 :     hash_ctl.entrysize = sizeof(plperl_interp_desc);
     463          42 :     plperl_interp_hash = hash_create("PL/Perl interpreters",
     464             :                                      8,
     465             :                                      &hash_ctl,
     466             :                                      HASH_ELEM | HASH_BLOBS);
     467             : 
     468          42 :     hash_ctl.keysize = sizeof(plperl_proc_key);
     469          42 :     hash_ctl.entrysize = sizeof(plperl_proc_ptr);
     470          42 :     plperl_proc_hash = hash_create("PL/Perl procedures",
     471             :                                    32,
     472             :                                    &hash_ctl,
     473             :                                    HASH_ELEM | HASH_BLOBS);
     474             : 
     475             :     /*
     476             :      * Save the default opmask.
     477             :      */
     478          42 :     PLPERL_SET_OPMASK(plperl_opmask);
     479             : 
     480             :     /*
     481             :      * Create the first Perl interpreter, but only partially initialize it.
     482             :      */
     483          42 :     plperl_held_interp = plperl_init_interp();
     484             : 
     485          42 :     inited = true;
     486             : }
     487             : 
     488             : 
     489             : static void
     490          92 : set_interp_require(bool trusted)
     491             : {
     492          92 :     if (trusted)
     493             :     {
     494          56 :         PL_ppaddr[OP_REQUIRE] = pp_require_safe;
     495          56 :         PL_ppaddr[OP_DOFILE] = pp_require_safe;
     496             :     }
     497             :     else
     498             :     {
     499          36 :         PL_ppaddr[OP_REQUIRE] = pp_require_orig;
     500          36 :         PL_ppaddr[OP_DOFILE] = pp_require_orig;
     501             :     }
     502          92 : }
     503             : 
     504             : /*
     505             :  * Cleanup perl interpreters, including running END blocks.
     506             :  * Does not fully undo the actions of _PG_init() nor make it callable again.
     507             :  */
     508             : static void
     509          38 : plperl_fini(int code, Datum arg)
     510             : {
     511             :     HASH_SEQ_STATUS hash_seq;
     512             :     plperl_interp_desc *interp_desc;
     513             : 
     514          38 :     elog(DEBUG3, "plperl_fini");
     515             : 
     516             :     /*
     517             :      * Indicate that perl is terminating. Disables use of spi_* functions when
     518             :      * running END/DESTROY code. See check_spi_usage_allowed(). Could be
     519             :      * enabled in future, with care, using a transaction
     520             :      * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
     521             :      */
     522          38 :     plperl_ending = true;
     523             : 
     524             :     /* Only perform perl cleanup if we're exiting cleanly */
     525          38 :     if (code)
     526             :     {
     527           0 :         elog(DEBUG3, "plperl_fini: skipped");
     528           0 :         return;
     529             :     }
     530             : 
     531             :     /* Zap the "held" interpreter, if we still have it */
     532          38 :     plperl_destroy_interp(&plperl_held_interp);
     533             : 
     534             :     /* Zap any fully-initialized interpreters */
     535          38 :     hash_seq_init(&hash_seq, plperl_interp_hash);
     536          78 :     while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
     537             :     {
     538          40 :         if (interp_desc->interp)
     539             :         {
     540          40 :             activate_interpreter(interp_desc);
     541          40 :             plperl_destroy_interp(&interp_desc->interp);
     542             :         }
     543             :     }
     544             : 
     545          38 :     elog(DEBUG3, "plperl_fini: done");
     546             : }
     547             : 
     548             : 
     549             : /*
     550             :  * Select and activate an appropriate Perl interpreter.
     551             :  */
     552             : static void
     553         328 : select_perl_context(bool trusted)
     554             : {
     555             :     Oid         user_id;
     556             :     plperl_interp_desc *interp_desc;
     557             :     bool        found;
     558         328 :     PerlInterpreter *interp = NULL;
     559             : 
     560             :     /* Find or create the interpreter hashtable entry for this userid */
     561         328 :     if (trusted)
     562         278 :         user_id = GetUserId();
     563             :     else
     564          50 :         user_id = InvalidOid;
     565             : 
     566         328 :     interp_desc = hash_search(plperl_interp_hash, &user_id,
     567             :                               HASH_ENTER,
     568             :                               &found);
     569         328 :     if (!found)
     570             :     {
     571             :         /* Initialize newly-created hashtable entry */
     572          42 :         interp_desc->interp = NULL;
     573          42 :         interp_desc->query_hash = NULL;
     574             :     }
     575             : 
     576             :     /* Make sure we have a query_hash for this interpreter */
     577         328 :     if (interp_desc->query_hash == NULL)
     578             :     {
     579             :         HASHCTL     hash_ctl;
     580             : 
     581          42 :         hash_ctl.keysize = NAMEDATALEN;
     582          42 :         hash_ctl.entrysize = sizeof(plperl_query_entry);
     583          42 :         interp_desc->query_hash = hash_create("PL/Perl queries",
     584             :                                               32,
     585             :                                               &hash_ctl,
     586             :                                               HASH_ELEM | HASH_STRINGS);
     587             :     }
     588             : 
     589             :     /*
     590             :      * Quick exit if already have an interpreter
     591             :      */
     592         328 :     if (interp_desc->interp)
     593             :     {
     594         286 :         activate_interpreter(interp_desc);
     595         286 :         return;
     596             :     }
     597             : 
     598             :     /*
     599             :      * adopt held interp if free, else create new one if possible
     600             :      */
     601          42 :     if (plperl_held_interp != NULL)
     602             :     {
     603             :         /* first actual use of a perl interpreter */
     604          40 :         interp = plperl_held_interp;
     605             : 
     606             :         /*
     607             :          * Reset the plperl_held_interp pointer first; if we fail during init
     608             :          * we don't want to try again with the partially-initialized interp.
     609             :          */
     610          40 :         plperl_held_interp = NULL;
     611             : 
     612          40 :         if (trusted)
     613          32 :             plperl_trusted_init();
     614             :         else
     615           8 :             plperl_untrusted_init();
     616             : 
     617             :         /* successfully initialized, so arrange for cleanup */
     618          38 :         on_proc_exit(plperl_fini, 0);
     619             :     }
     620             :     else
     621             :     {
     622             : #ifdef MULTIPLICITY
     623             : 
     624             :         /*
     625             :          * plperl_init_interp will change Perl's idea of the active
     626             :          * interpreter.  Reset plperl_active_interp temporarily, so that if we
     627             :          * hit an error partway through here, we'll make sure to switch back
     628             :          * to a non-broken interpreter before running any other Perl
     629             :          * functions.
     630             :          */
     631           2 :         plperl_active_interp = NULL;
     632             : 
     633             :         /* Now build the new interpreter */
     634           2 :         interp = plperl_init_interp();
     635             : 
     636           2 :         if (trusted)
     637           0 :             plperl_trusted_init();
     638             :         else
     639           2 :             plperl_untrusted_init();
     640             : #else
     641             :         ereport(ERROR,
     642             :                 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
     643             :                  errmsg("cannot allocate multiple Perl interpreters on this platform")));
     644             : #endif
     645             :     }
     646             : 
     647          40 :     set_interp_require(trusted);
     648             : 
     649             :     /*
     650             :      * Since the timing of first use of PL/Perl can't be predicted, any
     651             :      * database interaction during initialization is problematic. Including,
     652             :      * but not limited to, security definer issues. So we only enable access
     653             :      * to the database AFTER on_*_init code has run. See
     654             :      * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
     655             :      */
     656             :     {
     657          40 :         dTHX;
     658             : 
     659          40 :         newXS("PostgreSQL::InServer::SPI::bootstrap",
     660             :               boot_PostgreSQL__InServer__SPI, __FILE__);
     661             : 
     662          40 :         eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
     663          40 :         if (SvTRUE(ERRSV))
     664           0 :             ereport(ERROR,
     665             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
     666             :                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
     667             :                      errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
     668             :     }
     669             : 
     670             :     /* Fully initialized, so mark the hashtable entry valid */
     671          40 :     interp_desc->interp = interp;
     672             : 
     673             :     /* And mark this as the active interpreter */
     674          40 :     plperl_active_interp = interp_desc;
     675             : }
     676             : 
     677             : /*
     678             :  * Make the specified interpreter the active one
     679             :  *
     680             :  * A call with NULL does nothing.  This is so that "restoring" to a previously
     681             :  * null state of plperl_active_interp doesn't result in useless thrashing.
     682             :  */
     683             : static void
     684        1818 : activate_interpreter(plperl_interp_desc *interp_desc)
     685             : {
     686        1818 :     if (interp_desc && plperl_active_interp != interp_desc)
     687             :     {
     688             :         Assert(interp_desc->interp);
     689          52 :         PERL_SET_CONTEXT(interp_desc->interp);
     690             :         /* trusted iff user_id isn't InvalidOid */
     691          52 :         set_interp_require(OidIsValid(interp_desc->user_id));
     692          52 :         plperl_active_interp = interp_desc;
     693             :     }
     694        1818 : }
     695             : 
     696             : /*
     697             :  * Create a new Perl interpreter.
     698             :  *
     699             :  * We initialize the interpreter as far as we can without knowing whether
     700             :  * it will become a trusted or untrusted interpreter; in particular, the
     701             :  * plperl.on_init code will get executed.  Later, either plperl_trusted_init
     702             :  * or plperl_untrusted_init must be called to complete the initialization.
     703             :  */
     704             : static PerlInterpreter *
     705          44 : plperl_init_interp(void)
     706             : {
     707             :     PerlInterpreter *plperl;
     708             : 
     709             :     static char *embedding[3 + 2] = {
     710             :         "", "-e", PLC_PERLBOOT
     711             :     };
     712          44 :     int         nargs = 3;
     713             : 
     714             : #ifdef WIN32
     715             : 
     716             :     /*
     717             :      * The perl library on startup does horrible things like call
     718             :      * setlocale(LC_ALL,""). We have protected against that on most platforms
     719             :      * by setting the environment appropriately. However, on Windows,
     720             :      * setlocale() does not consult the environment, so we need to save the
     721             :      * existing locale settings before perl has a chance to mangle them and
     722             :      * restore them after its dirty deeds are done.
     723             :      *
     724             :      * MSDN ref:
     725             :      * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
     726             :      *
     727             :      * It appears that we only need to do this on interpreter startup, and
     728             :      * subsequent calls to the interpreter don't mess with the locale
     729             :      * settings.
     730             :      *
     731             :      * We restore them using setlocale_perl(), defined below, so that Perl
     732             :      * doesn't have a different idea of the locale from Postgres.
     733             :      *
     734             :      */
     735             : 
     736             :     char       *loc;
     737             :     char       *save_collate,
     738             :                *save_ctype,
     739             :                *save_monetary,
     740             :                *save_numeric,
     741             :                *save_time;
     742             : 
     743             :     loc = setlocale(LC_COLLATE, NULL);
     744             :     save_collate = loc ? pstrdup(loc) : NULL;
     745             :     loc = setlocale(LC_CTYPE, NULL);
     746             :     save_ctype = loc ? pstrdup(loc) : NULL;
     747             :     loc = setlocale(LC_MONETARY, NULL);
     748             :     save_monetary = loc ? pstrdup(loc) : NULL;
     749             :     loc = setlocale(LC_NUMERIC, NULL);
     750             :     save_numeric = loc ? pstrdup(loc) : NULL;
     751             :     loc = setlocale(LC_TIME, NULL);
     752             :     save_time = loc ? pstrdup(loc) : NULL;
     753             : 
     754             : #define PLPERL_RESTORE_LOCALE(name, saved) \
     755             :     STMT_START { \
     756             :         if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
     757             :     } STMT_END
     758             : #endif                          /* WIN32 */
     759             : 
     760          44 :     if (plperl_on_init && *plperl_on_init)
     761             :     {
     762           0 :         embedding[nargs++] = "-e";
     763           0 :         embedding[nargs++] = plperl_on_init;
     764             :     }
     765             : 
     766             :     /*
     767             :      * The perl API docs state that PERL_SYS_INIT3 should be called before
     768             :      * allocating interpreters. Unfortunately, on some platforms this fails in
     769             :      * the Perl_do_taint() routine, which is called when the platform is using
     770             :      * the system's malloc() instead of perl's own. Other platforms, notably
     771             :      * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
     772             :      * available, unless perl is using the system malloc(), which is true when
     773             :      * MYMALLOC is set.
     774             :      */
     775             : #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
     776             :     {
     777             :         static int  perl_sys_init_done;
     778             : 
     779             :         /* only call this the first time through, as per perlembed man page */
     780          44 :         if (!perl_sys_init_done)
     781             :         {
     782          42 :             char       *dummy_env[1] = {NULL};
     783             : 
     784          42 :             PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
     785             : 
     786             :             /*
     787             :              * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to
     788             :              * SIG_IGN.  Aside from being extremely unfriendly behavior for a
     789             :              * library, this is dumb on the grounds that the results of a
     790             :              * SIGFPE in this state are undefined according to POSIX, and in
     791             :              * fact you get a forced process kill at least on Linux.  Hence,
     792             :              * restore the SIGFPE handler to the backend's standard setting.
     793             :              * (See Perl bug 114574 for more information.)
     794             :              */
     795          42 :             pqsignal(SIGFPE, FloatExceptionHandler);
     796             : 
     797          42 :             perl_sys_init_done = 1;
     798             :             /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
     799          42 :             dummy_env[0] = NULL;
     800             :         }
     801             :     }
     802             : #endif
     803             : 
     804          44 :     plperl = perl_alloc();
     805          44 :     if (!plperl)
     806           0 :         elog(ERROR, "could not allocate Perl interpreter");
     807             : 
     808          44 :     PERL_SET_CONTEXT(plperl);
     809          44 :     perl_construct(plperl);
     810             : 
     811             :     /*
     812             :      * Run END blocks in perl_destruct instead of perl_run.  Note that dTHX
     813             :      * loads up a pointer to the current interpreter, so we have to postpone
     814             :      * it to here rather than put it at the function head.
     815             :      */
     816             :     {
     817          44 :         dTHX;
     818             : 
     819          44 :         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
     820             : 
     821             :         /*
     822             :          * Record the original function for the 'require' and 'dofile'
     823             :          * opcodes.  (They share the same implementation.)  Ensure it's used
     824             :          * for new interpreters.
     825             :          */
     826          44 :         if (!pp_require_orig)
     827          42 :             pp_require_orig = PL_ppaddr[OP_REQUIRE];
     828             :         else
     829             :         {
     830           2 :             PL_ppaddr[OP_REQUIRE] = pp_require_orig;
     831           2 :             PL_ppaddr[OP_DOFILE] = pp_require_orig;
     832             :         }
     833             : 
     834             : #ifdef PLPERL_ENABLE_OPMASK_EARLY
     835             : 
     836             :         /*
     837             :          * For regression testing to prove that the PLC_PERLBOOT and
     838             :          * PLC_TRUSTED code doesn't even compile any unsafe ops.  In future
     839             :          * there may be a valid need for them to do so, in which case this
     840             :          * could be softened (perhaps moved to plperl_trusted_init()) or
     841             :          * removed.
     842             :          */
     843             :         PL_op_mask = plperl_opmask;
     844             : #endif
     845             : 
     846          44 :         if (perl_parse(plperl, plperl_init_shared_libs,
     847             :                        nargs, embedding, NULL) != 0)
     848           0 :             ereport(ERROR,
     849             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
     850             :                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
     851             :                      errcontext("while parsing Perl initialization")));
     852             : 
     853          44 :         if (perl_run(plperl) != 0)
     854           0 :             ereport(ERROR,
     855             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
     856             :                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
     857             :                      errcontext("while running Perl initialization")));
     858             : 
     859             : #ifdef PLPERL_RESTORE_LOCALE
     860             :         PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
     861             :         PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
     862             :         PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
     863             :         PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
     864             :         PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
     865             : #endif
     866             :     }
     867             : 
     868          44 :     return plperl;
     869             : }
     870             : 
     871             : 
     872             : /*
     873             :  * Our safe implementation of the require opcode.
     874             :  * This is safe because it's completely unable to load any code.
     875             :  * If the requested file/module has already been loaded it'll return true.
     876             :  * If not, it'll die.
     877             :  * So now "use Foo;" will work iff Foo has already been loaded.
     878             :  */
     879             : static OP  *
     880          16 : pp_require_safe(pTHX)
     881             : {
     882             :     dVAR;
     883          16 :     dSP;
     884             :     SV         *sv,
     885             :               **svp;
     886             :     char       *name;
     887             :     STRLEN      len;
     888             : 
     889          16 :     sv = POPs;
     890          16 :     name = SvPV(sv, len);
     891          16 :     if (!(name && len > 0 && *name))
     892           0 :         RETPUSHNO;
     893             : 
     894          16 :     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
     895          16 :     if (svp && *svp != &PL_sv_undef)
     896           8 :         RETPUSHYES;
     897             : 
     898           8 :     DIE(aTHX_ "Unable to load %s into plperl", name);
     899             : 
     900             :     /*
     901             :      * In most Perl versions, DIE() expands to a return statement, so the next
     902             :      * line is not necessary.  But in versions between but not including
     903             :      * 5.11.1 and 5.13.3 it does not, so the next line is necessary to avoid a
     904             :      * "control reaches end of non-void function" warning from gcc.  Other
     905             :      * compilers such as Solaris Studio will, however, issue a "statement not
     906             :      * reached" warning instead.
     907             :      */
     908             :     return NULL;
     909             : }
     910             : 
     911             : 
     912             : /*
     913             :  * Destroy one Perl interpreter ... actually we just run END blocks.
     914             :  *
     915             :  * Caller must have ensured this interpreter is the active one.
     916             :  */
     917             : static void
     918          78 : plperl_destroy_interp(PerlInterpreter **interp)
     919             : {
     920          78 :     if (interp && *interp)
     921             :     {
     922             :         /*
     923             :          * Only a very minimal destruction is performed: - just call END
     924             :          * blocks.
     925             :          *
     926             :          * We could call perl_destruct() but we'd need to audit its actions
     927             :          * very carefully and work-around any that impact us. (Calling
     928             :          * sv_clean_objs() isn't an option because it's not part of perl's
     929             :          * public API so isn't portably available.) Meanwhile END blocks can
     930             :          * be used to perform manual cleanup.
     931             :          */
     932          40 :         dTHX;
     933             : 
     934             :         /* Run END blocks - based on perl's perl_destruct() */
     935          40 :         if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
     936             :         {
     937             :             dJMPENV;
     938          40 :             int         x = 0;
     939             : 
     940          40 :             JMPENV_PUSH(x);
     941             :             PERL_UNUSED_VAR(x);
     942          40 :             if (PL_endav && !PL_minus_c)
     943           0 :                 call_list(PL_scopestack_ix, PL_endav);
     944          40 :             JMPENV_POP;
     945             :         }
     946          40 :         LEAVE;
     947          40 :         FREETMPS;
     948             : 
     949          40 :         *interp = NULL;
     950             :     }
     951          78 : }
     952             : 
     953             : /*
     954             :  * Initialize the current Perl interpreter as a trusted interp
     955             :  */
     956             : static void
     957          32 : plperl_trusted_init(void)
     958             : {
     959          32 :     dTHX;
     960             :     HV         *stash;
     961             :     SV         *sv;
     962             :     char       *key;
     963             :     I32         klen;
     964             : 
     965             :     /* use original require while we set up */
     966          32 :     PL_ppaddr[OP_REQUIRE] = pp_require_orig;
     967          32 :     PL_ppaddr[OP_DOFILE] = pp_require_orig;
     968             : 
     969          32 :     eval_pv(PLC_TRUSTED, FALSE);
     970          32 :     if (SvTRUE(ERRSV))
     971           0 :         ereport(ERROR,
     972             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
     973             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
     974             :                  errcontext("while executing PLC_TRUSTED")));
     975             : 
     976             :     /*
     977             :      * Force loading of utf8 module now to prevent errors that can arise from
     978             :      * the regex code later trying to load utf8 modules. See
     979             :      * http://rt.perl.org/rt3/Ticket/Display.html?id=47576
     980             :      */
     981          32 :     eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
     982          32 :     if (SvTRUE(ERRSV))
     983           0 :         ereport(ERROR,
     984             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
     985             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
     986             :                  errcontext("while executing utf8fix")));
     987             : 
     988             :     /*
     989             :      * Lock down the interpreter
     990             :      */
     991             : 
     992             :     /* switch to the safe require/dofile opcode for future code */
     993          32 :     PL_ppaddr[OP_REQUIRE] = pp_require_safe;
     994          32 :     PL_ppaddr[OP_DOFILE] = pp_require_safe;
     995             : 
     996             :     /*
     997             :      * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
     998             :      * interpreter, so this only needs to be set once
     999             :      */
    1000          32 :     PL_op_mask = plperl_opmask;
    1001             : 
    1002             :     /* delete the DynaLoader:: namespace so extensions can't be loaded */
    1003          32 :     stash = gv_stashpv("DynaLoader", GV_ADDWARN);
    1004          32 :     hv_iterinit(stash);
    1005          64 :     while ((sv = hv_iternextsv(stash, &key, &klen)))
    1006             :     {
    1007          32 :         if (!isGV_with_GP(sv) || !GvCV(sv))
    1008           0 :             continue;
    1009          32 :         SvREFCNT_dec(GvCV(sv)); /* free the CV */
    1010          32 :         GvCV_set(sv, NULL);     /* prevent call via GV */
    1011             :     }
    1012          32 :     hv_clear(stash);
    1013             : 
    1014             :     /* invalidate assorted caches */
    1015          32 :     ++PL_sub_generation;
    1016          32 :     hv_clear(PL_stashcache);
    1017             : 
    1018             :     /*
    1019             :      * Execute plperl.on_plperl_init in the locked-down interpreter
    1020             :      */
    1021          32 :     if (plperl_on_plperl_init && *plperl_on_plperl_init)
    1022             :     {
    1023           4 :         eval_pv(plperl_on_plperl_init, FALSE);
    1024             :         /* XXX need to find a way to determine a better errcode here */
    1025           4 :         if (SvTRUE(ERRSV))
    1026           2 :             ereport(ERROR,
    1027             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1028             :                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
    1029             :                      errcontext("while executing plperl.on_plperl_init")));
    1030             :     }
    1031          30 : }
    1032             : 
    1033             : 
    1034             : /*
    1035             :  * Initialize the current Perl interpreter as an untrusted interp
    1036             :  */
    1037             : static void
    1038          10 : plperl_untrusted_init(void)
    1039             : {
    1040          10 :     dTHX;
    1041             : 
    1042             :     /*
    1043             :      * Nothing to do except execute plperl.on_plperlu_init
    1044             :      */
    1045          10 :     if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
    1046             :     {
    1047           2 :         eval_pv(plperl_on_plperlu_init, FALSE);
    1048           2 :         if (SvTRUE(ERRSV))
    1049           0 :             ereport(ERROR,
    1050             :                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    1051             :                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
    1052             :                      errcontext("while executing plperl.on_plperlu_init")));
    1053             :     }
    1054          10 : }
    1055             : 
    1056             : 
    1057             : /*
    1058             :  * Perl likes to put a newline after its error messages; clean up such
    1059             :  */
    1060             : static char *
    1061          52 : strip_trailing_ws(const char *msg)
    1062             : {
    1063          52 :     char       *res = pstrdup(msg);
    1064          52 :     int         len = strlen(res);
    1065             : 
    1066         104 :     while (len > 0 && isspace((unsigned char) res[len - 1]))
    1067          52 :         res[--len] = '\0';
    1068          52 :     return res;
    1069             : }
    1070             : 
    1071             : 
    1072             : /* Build a tuple from a hash. */
    1073             : 
    1074             : static HeapTuple
    1075         160 : plperl_build_tuple_result(HV *perlhash, TupleDesc td)
    1076             : {
    1077         160 :     dTHX;
    1078             :     Datum      *values;
    1079             :     bool       *nulls;
    1080             :     HE         *he;
    1081             :     HeapTuple   tup;
    1082             : 
    1083         160 :     values = palloc0(sizeof(Datum) * td->natts);
    1084         160 :     nulls = palloc(sizeof(bool) * td->natts);
    1085         160 :     memset(nulls, true, sizeof(bool) * td->natts);
    1086             : 
    1087         160 :     hv_iterinit(perlhash);
    1088         530 :     while ((he = hv_iternext(perlhash)))
    1089             :     {
    1090         374 :         SV         *val = HeVAL(he);
    1091         374 :         char       *key = hek2cstr(he);
    1092         374 :         int         attn = SPI_fnumber(td, key);
    1093         374 :         Form_pg_attribute attr = TupleDescAttr(td, attn - 1);
    1094             : 
    1095         374 :         if (attn == SPI_ERROR_NOATTRIBUTE)
    1096           4 :             ereport(ERROR,
    1097             :                     (errcode(ERRCODE_UNDEFINED_COLUMN),
    1098             :                      errmsg("Perl hash contains nonexistent column \"%s\"",
    1099             :                             key)));
    1100         370 :         if (attn <= 0)
    1101           0 :             ereport(ERROR,
    1102             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1103             :                      errmsg("cannot set system attribute \"%s\"",
    1104             :                             key)));
    1105             : 
    1106         740 :         values[attn - 1] = plperl_sv_to_datum(val,
    1107             :                                               attr->atttypid,
    1108             :                                               attr->atttypmod,
    1109             :                                               NULL,
    1110             :                                               NULL,
    1111             :                                               InvalidOid,
    1112         370 :                                               &nulls[attn - 1]);
    1113             : 
    1114         370 :         pfree(key);
    1115             :     }
    1116         156 :     hv_iterinit(perlhash);
    1117             : 
    1118         156 :     tup = heap_form_tuple(td, values, nulls);
    1119         156 :     pfree(values);
    1120         156 :     pfree(nulls);
    1121         156 :     return tup;
    1122             : }
    1123             : 
    1124             : /* convert a hash reference to a datum */
    1125             : static Datum
    1126          82 : plperl_hash_to_datum(SV *src, TupleDesc td)
    1127             : {
    1128          82 :     HeapTuple   tup = plperl_build_tuple_result((HV *) SvRV(src), td);
    1129             : 
    1130          80 :     return HeapTupleGetDatum(tup);
    1131             : }
    1132             : 
    1133             : /*
    1134             :  * if we are an array ref return the reference. this is special in that if we
    1135             :  * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array.
    1136             :  */
    1137             : static SV  *
    1138         700 : get_perl_array_ref(SV *sv)
    1139             : {
    1140         700 :     dTHX;
    1141             : 
    1142         700 :     if (SvOK(sv) && SvROK(sv))
    1143             :     {
    1144         374 :         if (SvTYPE(SvRV(sv)) == SVt_PVAV)
    1145         268 :             return sv;
    1146         106 :         else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY"))
    1147             :         {
    1148           2 :             HV         *hv = (HV *) SvRV(sv);
    1149           2 :             SV        **sav = hv_fetch_string(hv, "array");
    1150             : 
    1151           2 :             if (*sav && SvOK(*sav) && SvROK(*sav) &&
    1152           2 :                 SvTYPE(SvRV(*sav)) == SVt_PVAV)
    1153           2 :                 return *sav;
    1154             : 
    1155           0 :             elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
    1156             :         }
    1157             :     }
    1158         430 :     return NULL;
    1159             : }
    1160             : 
    1161             : /*
    1162             :  * helper function for plperl_array_to_datum, recurses for multi-D arrays
    1163             :  */
    1164             : static void
    1165         230 : array_to_datum_internal(AV *av, ArrayBuildState *astate,
    1166             :                         int *ndims, int *dims, int cur_depth,
    1167             :                         Oid arraytypid, Oid elemtypid, int32 typmod,
    1168             :                         FmgrInfo *finfo, Oid typioparam)
    1169             : {
    1170         230 :     dTHX;
    1171             :     int         i;
    1172         230 :     int         len = av_len(av) + 1;
    1173             : 
    1174         694 :     for (i = 0; i < len; i++)
    1175             :     {
    1176             :         /* fetch the array element */
    1177         464 :         SV        **svp = av_fetch(av, i, FALSE);
    1178             : 
    1179             :         /* see if this element is an array, if so get that */
    1180         464 :         SV         *sav = svp ? get_perl_array_ref(*svp) : NULL;
    1181             : 
    1182             :         /* multi-dimensional array? */
    1183         464 :         if (sav)
    1184             :         {
    1185         172 :             AV         *nav = (AV *) SvRV(sav);
    1186             : 
    1187             :             /* dimensionality checks */
    1188         172 :             if (cur_depth + 1 > MAXDIM)
    1189           0 :                 ereport(ERROR,
    1190             :                         (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
    1191             :                          errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
    1192             :                                 cur_depth + 1, MAXDIM)));
    1193             : 
    1194             :             /* set size when at first element in this level, else compare */
    1195         172 :             if (i == 0 && *ndims == cur_depth)
    1196             :             {
    1197          32 :                 dims[*ndims] = av_len(nav) + 1;
    1198          32 :                 (*ndims)++;
    1199             :             }
    1200         140 :             else if (av_len(nav) + 1 != dims[cur_depth])
    1201           0 :                 ereport(ERROR,
    1202             :                         (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
    1203             :                          errmsg("multidimensional arrays must have array expressions with matching dimensions")));
    1204             : 
    1205             :             /* recurse to fetch elements of this sub-array */
    1206         172 :             array_to_datum_internal(nav, astate,
    1207             :                                     ndims, dims, cur_depth + 1,
    1208             :                                     arraytypid, elemtypid, typmod,
    1209             :                                     finfo, typioparam);
    1210             :         }
    1211             :         else
    1212             :         {
    1213             :             Datum       dat;
    1214             :             bool        isnull;
    1215             : 
    1216             :             /* scalar after some sub-arrays at same level? */
    1217         292 :             if (*ndims != cur_depth)
    1218           0 :                 ereport(ERROR,
    1219             :                         (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
    1220             :                          errmsg("multidimensional arrays must have array expressions with matching dimensions")));
    1221             : 
    1222         292 :             dat = plperl_sv_to_datum(svp ? *svp : NULL,
    1223             :                                      elemtypid,
    1224             :                                      typmod,
    1225             :                                      NULL,
    1226             :                                      finfo,
    1227             :                                      typioparam,
    1228             :                                      &isnull);
    1229             : 
    1230         292 :             (void) accumArrayResult(astate, dat, isnull,
    1231             :                                     elemtypid, CurrentMemoryContext);
    1232             :         }
    1233             :     }
    1234         230 : }
    1235             : 
    1236             : /*
    1237             :  * convert perl array ref to a datum
    1238             :  */
    1239             : static Datum
    1240          62 : plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
    1241             : {
    1242          62 :     dTHX;
    1243             :     ArrayBuildState *astate;
    1244             :     Oid         elemtypid;
    1245             :     FmgrInfo    finfo;
    1246             :     Oid         typioparam;
    1247             :     int         dims[MAXDIM];
    1248             :     int         lbs[MAXDIM];
    1249          62 :     int         ndims = 1;
    1250             :     int         i;
    1251             : 
    1252          62 :     elemtypid = get_element_type(typid);
    1253          62 :     if (!elemtypid)
    1254           4 :         ereport(ERROR,
    1255             :                 (errcode(ERRCODE_DATATYPE_MISMATCH),
    1256             :                  errmsg("cannot convert Perl array to non-array type %s",
    1257             :                         format_type_be(typid))));
    1258             : 
    1259          58 :     astate = initArrayResult(elemtypid, CurrentMemoryContext, true);
    1260             : 
    1261          58 :     _sv_to_datum_finfo(elemtypid, &finfo, &typioparam);
    1262             : 
    1263          58 :     memset(dims, 0, sizeof(dims));
    1264          58 :     dims[0] = av_len((AV *) SvRV(src)) + 1;
    1265             : 
    1266          58 :     array_to_datum_internal((AV *) SvRV(src), astate,
    1267             :                             &ndims, dims, 1,
    1268             :                             typid, elemtypid, typmod,
    1269             :                             &finfo, typioparam);
    1270             : 
    1271             :     /* ensure we get zero-D array for no inputs, as per PG convention */
    1272          58 :     if (dims[0] <= 0)
    1273           2 :         ndims = 0;
    1274             : 
    1275         146 :     for (i = 0; i < ndims; i++)
    1276          88 :         lbs[i] = 1;
    1277             : 
    1278          58 :     return makeMdArrayResult(astate, ndims, dims, lbs,
    1279             :                              CurrentMemoryContext, true);
    1280             : }
    1281             : 
    1282             : /* Get the information needed to convert data to the specified PG type */
    1283             : static void
    1284         398 : _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
    1285             : {
    1286             :     Oid         typinput;
    1287             : 
    1288             :     /* XXX would be better to cache these lookups */
    1289         398 :     getTypeInputInfo(typid,
    1290             :                      &typinput, typioparam);
    1291         398 :     fmgr_info(typinput, finfo);
    1292         398 : }
    1293             : 
    1294             : /*
    1295             :  * convert Perl SV to PG datum of type typid, typmod typmod
    1296             :  *
    1297             :  * Pass the PL/Perl function's fcinfo when attempting to convert to the
    1298             :  * function's result type; otherwise pass NULL.  This is used when we need to
    1299             :  * resolve the actual result type of a function returning RECORD.
    1300             :  *
    1301             :  * finfo and typioparam should be the results of _sv_to_datum_finfo for the
    1302             :  * given typid, or NULL/InvalidOid to let this function do the lookups.
    1303             :  *
    1304             :  * *isnull is an output parameter.
    1305             :  */
    1306             : static Datum
    1307        1274 : plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
    1308             :                    FunctionCallInfo fcinfo,
    1309             :                    FmgrInfo *finfo, Oid typioparam,
    1310             :                    bool *isnull)
    1311             : {
    1312             :     FmgrInfo    tmp;
    1313             :     Oid         funcid;
    1314             : 
    1315             :     /* we might recurse */
    1316        1274 :     check_stack_depth();
    1317             : 
    1318        1274 :     *isnull = false;
    1319             : 
    1320             :     /*
    1321             :      * Return NULL if result is undef, or if we're in a function returning
    1322             :      * VOID.  In the latter case, we should pay no attention to the last Perl
    1323             :      * statement's result, and this is a convenient means to ensure that.
    1324             :      */
    1325        1274 :     if (!sv || !SvOK(sv) || typid == VOIDOID)
    1326             :     {
    1327             :         /* look up type info if they did not pass it */
    1328          78 :         if (!finfo)
    1329             :         {
    1330          10 :             _sv_to_datum_finfo(typid, &tmp, &typioparam);
    1331          10 :             finfo = &tmp;
    1332             :         }
    1333          78 :         *isnull = true;
    1334             :         /* must call typinput in case it wants to reject NULL */
    1335          78 :         return InputFunctionCall(finfo, NULL, typioparam, typmod);
    1336             :     }
    1337        1196 :     else if ((funcid = get_transform_tosql(typid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
    1338         156 :         return OidFunctionCall1(funcid, PointerGetDatum(sv));
    1339        1040 :     else if (SvROK(sv))
    1340             :     {
    1341             :         /* handle references */
    1342         152 :         SV         *sav = get_perl_array_ref(sv);
    1343             : 
    1344         152 :         if (sav)
    1345             :         {
    1346             :             /* handle an arrayref */
    1347          62 :             return plperl_array_to_datum(sav, typid, typmod);
    1348             :         }
    1349          90 :         else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
    1350             :         {
    1351             :             /* handle a hashref */
    1352             :             Datum       ret;
    1353             :             TupleDesc   td;
    1354             :             bool        isdomain;
    1355             : 
    1356          88 :             if (!type_is_rowtype(typid))
    1357           4 :                 ereport(ERROR,
    1358             :                         (errcode(ERRCODE_DATATYPE_MISMATCH),
    1359             :                          errmsg("cannot convert Perl hash to non-composite type %s",
    1360             :                                 format_type_be(typid))));
    1361             : 
    1362          84 :             td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
    1363          84 :             if (td != NULL)
    1364             :             {
    1365             :                 /* Did we look through a domain? */
    1366          68 :                 isdomain = (typid != td->tdtypeid);
    1367             :             }
    1368             :             else
    1369             :             {
    1370             :                 /* Must be RECORD, try to resolve based on call info */
    1371             :                 TypeFuncClass funcclass;
    1372             : 
    1373          16 :                 if (fcinfo)
    1374          16 :                     funcclass = get_call_result_type(fcinfo, &typid, &td);
    1375             :                 else
    1376           0 :                     funcclass = TYPEFUNC_OTHER;
    1377          16 :                 if (funcclass != TYPEFUNC_COMPOSITE &&
    1378             :                     funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
    1379           2 :                     ereport(ERROR,
    1380             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1381             :                              errmsg("function returning record called in context "
    1382             :                                     "that cannot accept type record")));
    1383             :                 Assert(td);
    1384          14 :                 isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
    1385             :             }
    1386             : 
    1387          82 :             ret = plperl_hash_to_datum(sv, td);
    1388             : 
    1389          80 :             if (isdomain)
    1390           8 :                 domain_check(ret, false, typid, NULL, NULL);
    1391             : 
    1392             :             /* Release on the result of get_call_result_type is harmless */
    1393          76 :             ReleaseTupleDesc(td);
    1394             : 
    1395          76 :             return ret;
    1396             :         }
    1397             : 
    1398             :         /*
    1399             :          * If it's a reference to something else, such as a scalar, just
    1400             :          * recursively look through the reference.
    1401             :          */
    1402           2 :         return plperl_sv_to_datum(SvRV(sv), typid, typmod,
    1403             :                                   fcinfo, finfo, typioparam,
    1404             :                                   isnull);
    1405             :     }
    1406             :     else
    1407             :     {
    1408             :         /* handle a string/number */
    1409             :         Datum       ret;
    1410         888 :         char       *str = sv2cstr(sv);
    1411             : 
    1412             :         /* did not pass in any typeinfo? look it up */
    1413         886 :         if (!finfo)
    1414             :         {
    1415         330 :             _sv_to_datum_finfo(typid, &tmp, &typioparam);
    1416         330 :             finfo = &tmp;
    1417             :         }
    1418             : 
    1419         886 :         ret = InputFunctionCall(finfo, str, typioparam, typmod);
    1420         884 :         pfree(str);
    1421             : 
    1422         884 :         return ret;
    1423             :     }
    1424             : }
    1425             : 
    1426             : /* Convert the perl SV to a string returned by the type output function */
    1427             : char *
    1428          32 : plperl_sv_to_literal(SV *sv, char *fqtypename)
    1429             : {
    1430          32 :     Datum       str = CStringGetDatum(fqtypename);
    1431          32 :     Oid         typid = DirectFunctionCall1(regtypein, str);
    1432             :     Oid         typoutput;
    1433             :     Datum       datum;
    1434             :     bool        typisvarlena,
    1435             :                 isnull;
    1436             : 
    1437          32 :     if (!OidIsValid(typid))
    1438           0 :         ereport(ERROR,
    1439             :                 (errcode(ERRCODE_UNDEFINED_OBJECT),
    1440             :                  errmsg("lookup failed for type %s", fqtypename)));
    1441             : 
    1442          32 :     datum = plperl_sv_to_datum(sv,
    1443             :                                typid, -1,
    1444             :                                NULL, NULL, InvalidOid,
    1445             :                                &isnull);
    1446             : 
    1447          30 :     if (isnull)
    1448           2 :         return NULL;
    1449             : 
    1450          28 :     getTypeOutputInfo(typid,
    1451             :                       &typoutput, &typisvarlena);
    1452             : 
    1453          28 :     return OidOutputFunctionCall(typoutput, datum);
    1454             : }
    1455             : 
    1456             : /*
    1457             :  * Convert PostgreSQL array datum to a perl array reference.
    1458             :  *
    1459             :  * typid is arg's OID, which must be an array type.
    1460             :  */
    1461             : static SV  *
    1462          34 : plperl_ref_from_pg_array(Datum arg, Oid typid)
    1463             : {
    1464          34 :     dTHX;
    1465          34 :     ArrayType  *ar = DatumGetArrayTypeP(arg);
    1466          34 :     Oid         elementtype = ARR_ELEMTYPE(ar);
    1467             :     int16       typlen;
    1468             :     bool        typbyval;
    1469             :     char        typalign,
    1470             :                 typdelim;
    1471             :     Oid         typioparam;
    1472             :     Oid         typoutputfunc;
    1473             :     Oid         transform_funcid;
    1474             :     int         i,
    1475             :                 nitems,
    1476             :                *dims;
    1477             :     plperl_array_info *info;
    1478             :     SV         *av;
    1479             :     HV         *hv;
    1480             : 
    1481             :     /*
    1482             :      * Currently we make no effort to cache any of the stuff we look up here,
    1483             :      * which is bad.
    1484             :      */
    1485          34 :     info = palloc0(sizeof(plperl_array_info));
    1486             : 
    1487             :     /* get element type information, including output conversion function */
    1488          34 :     get_type_io_data(elementtype, IOFunc_output,
    1489             :                      &typlen, &typbyval, &typalign,
    1490             :                      &typdelim, &typioparam, &typoutputfunc);
    1491             : 
    1492             :     /* Check for a transform function */
    1493          34 :     transform_funcid = get_transform_fromsql(elementtype,
    1494          34 :                                              current_call_data->prodesc->lang_oid,
    1495          34 :                                              current_call_data->prodesc->trftypes);
    1496             : 
    1497             :     /* Look up transform or output function as appropriate */
    1498          34 :     if (OidIsValid(transform_funcid))
    1499           2 :         fmgr_info(transform_funcid, &info->transform_proc);
    1500             :     else
    1501          32 :         fmgr_info(typoutputfunc, &info->proc);
    1502             : 
    1503          34 :     info->elem_is_rowtype = type_is_rowtype(elementtype);
    1504             : 
    1505             :     /* Get the number and bounds of array dimensions */
    1506          34 :     info->ndims = ARR_NDIM(ar);
    1507          34 :     dims = ARR_DIMS(ar);
    1508             : 
    1509             :     /* No dimensions? Return an empty array */
    1510          34 :     if (info->ndims == 0)
    1511             :     {
    1512           2 :         av = newRV_noinc((SV *) newAV());
    1513             :     }
    1514             :     else
    1515             :     {
    1516          32 :         deconstruct_array(ar, elementtype, typlen, typbyval,
    1517             :                           typalign, &info->elements, &info->nulls,
    1518             :                           &nitems);
    1519             : 
    1520             :         /* Get total number of elements in each dimension */
    1521          32 :         info->nelems = palloc(sizeof(int) * info->ndims);
    1522          32 :         info->nelems[0] = nitems;
    1523          56 :         for (i = 1; i < info->ndims; i++)
    1524          24 :             info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
    1525             : 
    1526          32 :         av = split_array(info, 0, nitems, 0);
    1527             :     }
    1528             : 
    1529          34 :     hv = newHV();
    1530          34 :     (void) hv_store(hv, "array", 5, av, 0);
    1531          34 :     (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0);
    1532             : 
    1533          34 :     return sv_bless(newRV_noinc((SV *) hv),
    1534             :                     gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
    1535             : }
    1536             : 
    1537             : /*
    1538             :  * Recursively form array references from splices of the initial array
    1539             :  */
    1540             : static SV  *
    1541         192 : split_array(plperl_array_info *info, int first, int last, int nest)
    1542             : {
    1543         192 :     dTHX;
    1544             :     int         i;
    1545             :     AV         *result;
    1546             : 
    1547             :     /* we should only be called when we have something to split */
    1548             :     Assert(info->ndims > 0);
    1549             : 
    1550             :     /* since this function recurses, it could be driven to stack overflow */
    1551         192 :     check_stack_depth();
    1552             : 
    1553             :     /*
    1554             :      * Base case, return a reference to a single-dimensional array
    1555             :      */
    1556         192 :     if (nest >= info->ndims - 1)
    1557         114 :         return make_array_ref(info, first, last);
    1558             : 
    1559          78 :     result = newAV();
    1560         238 :     for (i = first; i < last; i += info->nelems[nest + 1])
    1561             :     {
    1562             :         /* Recursively form references to arrays of lower dimensions */
    1563         160 :         SV         *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1);
    1564             : 
    1565         160 :         av_push(result, ref);
    1566             :     }
    1567          78 :     return newRV_noinc((SV *) result);
    1568             : }
    1569             : 
    1570             : /*
    1571             :  * Create a Perl reference from a one-dimensional C array, converting
    1572             :  * composite type elements to hash references.
    1573             :  */
    1574             : static SV  *
    1575         114 : make_array_ref(plperl_array_info *info, int first, int last)
    1576             : {
    1577         114 :     dTHX;
    1578             :     int         i;
    1579         114 :     AV         *result = newAV();
    1580             : 
    1581         386 :     for (i = first; i < last; i++)
    1582             :     {
    1583         272 :         if (info->nulls[i])
    1584             :         {
    1585             :             /*
    1586             :              * We can't use &PL_sv_undef here.  See "AVs, HVs and undefined
    1587             :              * values" in perlguts.
    1588             :              */
    1589           8 :             av_push(result, newSV(0));
    1590             :         }
    1591             :         else
    1592             :         {
    1593         264 :             Datum       itemvalue = info->elements[i];
    1594             : 
    1595         264 :             if (info->transform_proc.fn_oid)
    1596           4 :                 av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue)));
    1597         260 :             else if (info->elem_is_rowtype)
    1598             :                 /* Handle composite type elements */
    1599           8 :                 av_push(result, plperl_hash_from_datum(itemvalue));
    1600             :             else
    1601             :             {
    1602         252 :                 char       *val = OutputFunctionCall(&info->proc, itemvalue);
    1603             : 
    1604         252 :                 av_push(result, cstr2sv(val));
    1605             :             }
    1606             :         }
    1607             :     }
    1608         114 :     return newRV_noinc((SV *) result);
    1609             : }
    1610             : 
    1611             : /* Set up the arguments for a trigger call. */
    1612             : static SV  *
    1613          60 : plperl_trigger_build_args(FunctionCallInfo fcinfo)
    1614             : {
    1615          60 :     dTHX;
    1616             :     TriggerData *tdata;
    1617             :     TupleDesc   tupdesc;
    1618             :     int         i;
    1619             :     char       *level;
    1620             :     char       *event;
    1621             :     char       *relid;
    1622             :     char       *when;
    1623             :     HV         *hv;
    1624             : 
    1625          60 :     hv = newHV();
    1626          60 :     hv_ksplit(hv, 12);          /* pre-grow the hash */
    1627             : 
    1628          60 :     tdata = (TriggerData *) fcinfo->context;
    1629          60 :     tupdesc = tdata->tg_relation->rd_att;
    1630             : 
    1631          60 :     relid = DatumGetCString(DirectFunctionCall1(oidout,
    1632             :                                                 ObjectIdGetDatum(tdata->tg_relation->rd_id)));
    1633             : 
    1634          60 :     hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
    1635          60 :     hv_store_string(hv, "relid", cstr2sv(relid));
    1636             : 
    1637             :     /*
    1638             :      * Note: In BEFORE trigger, stored generated columns are not computed yet,
    1639             :      * so don't make them accessible in NEW row.
    1640             :      */
    1641             : 
    1642          60 :     if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
    1643             :     {
    1644          24 :         event = "INSERT";
    1645          24 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1646          24 :             hv_store_string(hv, "new",
    1647             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1648             :                                                    tupdesc,
    1649          24 :                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
    1650             :     }
    1651          36 :     else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
    1652             :     {
    1653          20 :         event = "DELETE";
    1654          20 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1655          20 :             hv_store_string(hv, "old",
    1656             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1657             :                                                    tupdesc,
    1658             :                                                    true));
    1659             :     }
    1660          16 :     else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
    1661             :     {
    1662          16 :         event = "UPDATE";
    1663          16 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1664             :         {
    1665          14 :             hv_store_string(hv, "old",
    1666             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1667             :                                                    tupdesc,
    1668             :                                                    true));
    1669          14 :             hv_store_string(hv, "new",
    1670             :                             plperl_hash_from_tuple(tdata->tg_newtuple,
    1671             :                                                    tupdesc,
    1672          14 :                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
    1673             :         }
    1674             :     }
    1675           0 :     else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
    1676           0 :         event = "TRUNCATE";
    1677             :     else
    1678           0 :         event = "UNKNOWN";
    1679             : 
    1680          60 :     hv_store_string(hv, "event", cstr2sv(event));
    1681          60 :     hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
    1682             : 
    1683          60 :     if (tdata->tg_trigger->tgnargs > 0)
    1684             :     {
    1685          24 :         AV         *av = newAV();
    1686             : 
    1687          24 :         av_extend(av, tdata->tg_trigger->tgnargs);
    1688          60 :         for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
    1689          36 :             av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
    1690          24 :         hv_store_string(hv, "args", newRV_noinc((SV *) av));
    1691             :     }
    1692             : 
    1693          60 :     hv_store_string(hv, "relname",
    1694          60 :                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
    1695             : 
    1696          60 :     hv_store_string(hv, "table_name",
    1697          60 :                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
    1698             : 
    1699          60 :     hv_store_string(hv, "table_schema",
    1700          60 :                     cstr2sv(SPI_getnspname(tdata->tg_relation)));
    1701             : 
    1702          60 :     if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
    1703          46 :         when = "BEFORE";
    1704          14 :     else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
    1705           8 :         when = "AFTER";
    1706           6 :     else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
    1707           6 :         when = "INSTEAD OF";
    1708             :     else
    1709           0 :         when = "UNKNOWN";
    1710          60 :     hv_store_string(hv, "when", cstr2sv(when));
    1711             : 
    1712          60 :     if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1713          58 :         level = "ROW";
    1714           2 :     else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
    1715           2 :         level = "STATEMENT";
    1716             :     else
    1717           0 :         level = "UNKNOWN";
    1718          60 :     hv_store_string(hv, "level", cstr2sv(level));
    1719             : 
    1720          60 :     return newRV_noinc((SV *) hv);
    1721             : }
    1722             : 
    1723             : 
    1724             : /* Set up the arguments for an event trigger call. */
    1725             : static SV  *
    1726          20 : plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
    1727             : {
    1728          20 :     dTHX;
    1729             :     EventTriggerData *tdata;
    1730             :     HV         *hv;
    1731             : 
    1732          20 :     hv = newHV();
    1733             : 
    1734          20 :     tdata = (EventTriggerData *) fcinfo->context;
    1735             : 
    1736          20 :     hv_store_string(hv, "event", cstr2sv(tdata->event));
    1737          20 :     hv_store_string(hv, "tag", cstr2sv(GetCommandTagName(tdata->tag)));
    1738             : 
    1739          20 :     return newRV_noinc((SV *) hv);
    1740             : }
    1741             : 
    1742             : /* Construct the modified new tuple to be returned from a trigger. */
    1743             : static HeapTuple
    1744          12 : plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
    1745             : {
    1746          12 :     dTHX;
    1747             :     SV        **svp;
    1748             :     HV         *hvNew;
    1749             :     HE         *he;
    1750             :     HeapTuple   rtup;
    1751             :     TupleDesc   tupdesc;
    1752             :     int         natts;
    1753             :     Datum      *modvalues;
    1754             :     bool       *modnulls;
    1755             :     bool       *modrepls;
    1756             : 
    1757          12 :     svp = hv_fetch_string(hvTD, "new");
    1758          12 :     if (!svp)
    1759           0 :         ereport(ERROR,
    1760             :                 (errcode(ERRCODE_UNDEFINED_COLUMN),
    1761             :                  errmsg("$_TD->{new} does not exist")));
    1762          12 :     if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
    1763           0 :         ereport(ERROR,
    1764             :                 (errcode(ERRCODE_DATATYPE_MISMATCH),
    1765             :                  errmsg("$_TD->{new} is not a hash reference")));
    1766          12 :     hvNew = (HV *) SvRV(*svp);
    1767             : 
    1768          12 :     tupdesc = tdata->tg_relation->rd_att;
    1769          12 :     natts = tupdesc->natts;
    1770             : 
    1771          12 :     modvalues = (Datum *) palloc0(natts * sizeof(Datum));
    1772          12 :     modnulls = (bool *) palloc0(natts * sizeof(bool));
    1773          12 :     modrepls = (bool *) palloc0(natts * sizeof(bool));
    1774             : 
    1775          12 :     hv_iterinit(hvNew);
    1776          42 :     while ((he = hv_iternext(hvNew)))
    1777             :     {
    1778          32 :         char       *key = hek2cstr(he);
    1779          32 :         SV         *val = HeVAL(he);
    1780          32 :         int         attn = SPI_fnumber(tupdesc, key);
    1781          32 :         Form_pg_attribute attr = TupleDescAttr(tupdesc, attn - 1);
    1782             : 
    1783          32 :         if (attn == SPI_ERROR_NOATTRIBUTE)
    1784           0 :             ereport(ERROR,
    1785             :                     (errcode(ERRCODE_UNDEFINED_COLUMN),
    1786             :                      errmsg("Perl hash contains nonexistent column \"%s\"",
    1787             :                             key)));
    1788          32 :         if (attn <= 0)
    1789           0 :             ereport(ERROR,
    1790             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1791             :                      errmsg("cannot set system attribute \"%s\"",
    1792             :                             key)));
    1793          32 :         if (attr->attgenerated)
    1794           2 :             ereport(ERROR,
    1795             :                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    1796             :                      errmsg("cannot set generated column \"%s\"",
    1797             :                             key)));
    1798             : 
    1799          60 :         modvalues[attn - 1] = plperl_sv_to_datum(val,
    1800             :                                                  attr->atttypid,
    1801             :                                                  attr->atttypmod,
    1802             :                                                  NULL,
    1803             :                                                  NULL,
    1804             :                                                  InvalidOid,
    1805          30 :                                                  &modnulls[attn - 1]);
    1806          30 :         modrepls[attn - 1] = true;
    1807             : 
    1808          30 :         pfree(key);
    1809             :     }
    1810          10 :     hv_iterinit(hvNew);
    1811             : 
    1812          10 :     rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls);
    1813             : 
    1814          10 :     pfree(modvalues);
    1815          10 :     pfree(modnulls);
    1816          10 :     pfree(modrepls);
    1817             : 
    1818          10 :     return rtup;
    1819             : }
    1820             : 
    1821             : 
    1822             : /*
    1823             :  * There are three externally visible pieces to plperl: plperl_call_handler,
    1824             :  * plperl_inline_handler, and plperl_validator.
    1825             :  */
    1826             : 
    1827             : /*
    1828             :  * The call handler is called to run normal functions (including trigger
    1829             :  * functions) that are defined in pg_proc.
    1830             :  */
    1831          42 : PG_FUNCTION_INFO_V1(plperl_call_handler);
    1832             : 
    1833             : Datum
    1834         536 : plperl_call_handler(PG_FUNCTION_ARGS)
    1835             : {
    1836         536 :     Datum       retval = (Datum) 0;
    1837         536 :     plperl_call_data *volatile save_call_data = current_call_data;
    1838         536 :     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
    1839             :     plperl_call_data this_call_data;
    1840             : 
    1841             :     /* Initialize current-call status record */
    1842        4288 :     MemSet(&this_call_data, 0, sizeof(this_call_data));
    1843         536 :     this_call_data.fcinfo = fcinfo;
    1844             : 
    1845         536 :     PG_TRY();
    1846             :     {
    1847         536 :         current_call_data = &this_call_data;
    1848         536 :         if (CALLED_AS_TRIGGER(fcinfo))
    1849          60 :             retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
    1850         476 :         else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
    1851             :         {
    1852          20 :             plperl_event_trigger_handler(fcinfo);
    1853          20 :             retval = (Datum) 0;
    1854             :         }
    1855             :         else
    1856         456 :             retval = plperl_func_handler(fcinfo);
    1857             :     }
    1858          76 :     PG_FINALLY();
    1859             :     {
    1860         536 :         current_call_data = save_call_data;
    1861         536 :         activate_interpreter(oldinterp);
    1862         536 :         if (this_call_data.prodesc)
    1863         534 :             decrement_prodesc_refcount(this_call_data.prodesc);
    1864             :     }
    1865         536 :     PG_END_TRY();
    1866             : 
    1867         460 :     return retval;
    1868             : }
    1869             : 
    1870             : /*
    1871             :  * The inline handler runs anonymous code blocks (DO blocks).
    1872             :  */
    1873          20 : PG_FUNCTION_INFO_V1(plperl_inline_handler);
    1874             : 
    1875             : Datum
    1876          36 : plperl_inline_handler(PG_FUNCTION_ARGS)
    1877             : {
    1878          36 :     LOCAL_FCINFO(fake_fcinfo, 0);
    1879          36 :     InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
    1880             :     FmgrInfo    flinfo;
    1881             :     plperl_proc_desc desc;
    1882          36 :     plperl_call_data *volatile save_call_data = current_call_data;
    1883          36 :     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
    1884             :     plperl_call_data this_call_data;
    1885             :     ErrorContextCallback pl_error_context;
    1886             : 
    1887             :     /* Initialize current-call status record */
    1888         288 :     MemSet(&this_call_data, 0, sizeof(this_call_data));
    1889             : 
    1890             :     /* Set up a callback for error reporting */
    1891          36 :     pl_error_context.callback = plperl_inline_callback;
    1892          36 :     pl_error_context.previous = error_context_stack;
    1893          36 :     pl_error_context.arg = NULL;
    1894          36 :     error_context_stack = &pl_error_context;
    1895             : 
    1896             :     /*
    1897             :      * Set up a fake fcinfo and descriptor with just enough info to satisfy
    1898             :      * plperl_call_perl_func().  In particular note that this sets things up
    1899             :      * with no arguments passed, and a result type of VOID.
    1900             :      */
    1901         180 :     MemSet(fake_fcinfo, 0, SizeForFunctionCallInfo(0));
    1902         252 :     MemSet(&flinfo, 0, sizeof(flinfo));
    1903         756 :     MemSet(&desc, 0, sizeof(desc));
    1904          36 :     fake_fcinfo->flinfo = &flinfo;
    1905          36 :     flinfo.fn_oid = InvalidOid;
    1906          36 :     flinfo.fn_mcxt = CurrentMemoryContext;
    1907             : 
    1908          36 :     desc.proname = "inline_code_block";
    1909          36 :     desc.fn_readonly = false;
    1910             : 
    1911          36 :     desc.lang_oid = codeblock->langOid;
    1912          36 :     desc.trftypes = NIL;
    1913          36 :     desc.lanpltrusted = codeblock->langIsTrusted;
    1914             : 
    1915          36 :     desc.fn_retistuple = false;
    1916          36 :     desc.fn_retisset = false;
    1917          36 :     desc.fn_retisarray = false;
    1918          36 :     desc.result_oid = InvalidOid;
    1919          36 :     desc.nargs = 0;
    1920          36 :     desc.reference = NULL;
    1921             : 
    1922          36 :     this_call_data.fcinfo = fake_fcinfo;
    1923          36 :     this_call_data.prodesc = &desc;
    1924             :     /* we do not bother with refcounting the fake prodesc */
    1925             : 
    1926          36 :     PG_TRY();
    1927             :     {
    1928             :         SV         *perlret;
    1929             : 
    1930          36 :         current_call_data = &this_call_data;
    1931             : 
    1932          36 :         if (SPI_connect_ext(codeblock->atomic ? 0 : SPI_OPT_NONATOMIC) != SPI_OK_CONNECT)
    1933           0 :             elog(ERROR, "could not connect to SPI manager");
    1934             : 
    1935          36 :         select_perl_context(desc.lanpltrusted);
    1936             : 
    1937          34 :         plperl_create_sub(&desc, codeblock->source_text, 0);
    1938             : 
    1939          24 :         if (!desc.reference)    /* can this happen? */
    1940           0 :             elog(ERROR, "could not create internal procedure for anonymous code block");
    1941             : 
    1942          24 :         perlret = plperl_call_perl_func(&desc, fake_fcinfo);
    1943             : 
    1944          16 :         SvREFCNT_dec_current(perlret);
    1945             : 
    1946          16 :         if (SPI_finish() != SPI_OK_FINISH)
    1947           0 :             elog(ERROR, "SPI_finish() failed");
    1948             :     }
    1949          20 :     PG_FINALLY();
    1950             :     {
    1951          36 :         if (desc.reference)
    1952          24 :             SvREFCNT_dec_current(desc.reference);
    1953          36 :         current_call_data = save_call_data;
    1954          36 :         activate_interpreter(oldinterp);
    1955             :     }
    1956          36 :     PG_END_TRY();
    1957             : 
    1958          16 :     error_context_stack = pl_error_context.previous;
    1959             : 
    1960          16 :     PG_RETURN_VOID();
    1961             : }
    1962             : 
    1963             : /*
    1964             :  * The validator is called during CREATE FUNCTION to validate the function
    1965             :  * being created/replaced. The precise behavior of the validator may be
    1966             :  * modified by the check_function_bodies GUC.
    1967             :  */
    1968          42 : PG_FUNCTION_INFO_V1(plperl_validator);
    1969             : 
    1970             : Datum
    1971         292 : plperl_validator(PG_FUNCTION_ARGS)
    1972             : {
    1973         292 :     Oid         funcoid = PG_GETARG_OID(0);
    1974             :     HeapTuple   tuple;
    1975             :     Form_pg_proc proc;
    1976             :     char        functyptype;
    1977             :     int         numargs;
    1978             :     Oid        *argtypes;
    1979             :     char      **argnames;
    1980             :     char       *argmodes;
    1981         292 :     bool        is_trigger = false;
    1982         292 :     bool        is_event_trigger = false;
    1983             :     int         i;
    1984             : 
    1985         292 :     if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid))
    1986           0 :         PG_RETURN_VOID();
    1987             : 
    1988             :     /* Get the new function's pg_proc entry */
    1989         292 :     tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
    1990         292 :     if (!HeapTupleIsValid(tuple))
    1991           0 :         elog(ERROR, "cache lookup failed for function %u", funcoid);
    1992         292 :     proc = (Form_pg_proc) GETSTRUCT(tuple);
    1993             : 
    1994         292 :     functyptype = get_typtype(proc->prorettype);
    1995             : 
    1996             :     /* Disallow pseudotype result */
    1997             :     /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
    1998         292 :     if (functyptype == TYPTYPE_PSEUDO)
    1999             :     {
    2000          76 :         if (proc->prorettype == TRIGGEROID)
    2001          16 :             is_trigger = true;
    2002          60 :         else if (proc->prorettype == EVENT_TRIGGEROID)
    2003           2 :             is_event_trigger = true;
    2004          58 :         else if (proc->prorettype != RECORDOID &&
    2005          36 :                  proc->prorettype != VOIDOID)
    2006           0 :             ereport(ERROR,
    2007             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2008             :                      errmsg("PL/Perl functions cannot return type %s",
    2009             :                             format_type_be(proc->prorettype))));
    2010             :     }
    2011             : 
    2012             :     /* Disallow pseudotypes in arguments (either IN or OUT) */
    2013         292 :     numargs = get_func_arg_info(tuple,
    2014             :                                 &argtypes, &argnames, &argmodes);
    2015         438 :     for (i = 0; i < numargs; i++)
    2016             :     {
    2017         146 :         if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO &&
    2018           2 :             argtypes[i] != RECORDOID)
    2019           0 :             ereport(ERROR,
    2020             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2021             :                      errmsg("PL/Perl functions cannot accept type %s",
    2022             :                             format_type_be(argtypes[i]))));
    2023             :     }
    2024             : 
    2025         292 :     ReleaseSysCache(tuple);
    2026             : 
    2027             :     /* Postpone body checks if !check_function_bodies */
    2028         292 :     if (check_function_bodies)
    2029             :     {
    2030         292 :         (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
    2031             :     }
    2032             : 
    2033             :     /* the result of a validator is ignored */
    2034         286 :     PG_RETURN_VOID();
    2035             : }
    2036             : 
    2037             : 
    2038             : /*
    2039             :  * plperlu likewise requires three externally visible functions:
    2040             :  * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator.
    2041             :  * These are currently just aliases that send control to the plperl
    2042             :  * handler functions, and we decide whether a particular function is
    2043             :  * trusted or not by inspecting the actual pg_language tuple.
    2044             :  */
    2045             : 
    2046          16 : PG_FUNCTION_INFO_V1(plperlu_call_handler);
    2047             : 
    2048             : Datum
    2049         100 : plperlu_call_handler(PG_FUNCTION_ARGS)
    2050             : {
    2051         100 :     return plperl_call_handler(fcinfo);
    2052             : }
    2053             : 
    2054          10 : PG_FUNCTION_INFO_V1(plperlu_inline_handler);
    2055             : 
    2056             : Datum
    2057           2 : plperlu_inline_handler(PG_FUNCTION_ARGS)
    2058             : {
    2059           2 :     return plperl_inline_handler(fcinfo);
    2060             : }
    2061             : 
    2062          18 : PG_FUNCTION_INFO_V1(plperlu_validator);
    2063             : 
    2064             : Datum
    2065          48 : plperlu_validator(PG_FUNCTION_ARGS)
    2066             : {
    2067             :     /* call plperl validator with our fcinfo so it gets our oid */
    2068          48 :     return plperl_validator(fcinfo);
    2069             : }
    2070             : 
    2071             : 
    2072             : /*
    2073             :  * Uses mkfunc to create a subroutine whose text is
    2074             :  * supplied in s, and returns a reference to it
    2075             :  */
    2076             : static void
    2077         326 : plperl_create_sub(plperl_proc_desc *prodesc, const char *s, Oid fn_oid)
    2078             : {
    2079         326 :     dTHX;
    2080         326 :     dSP;
    2081             :     char        subname[NAMEDATALEN + 40];
    2082         326 :     HV         *pragma_hv = newHV();
    2083         326 :     SV         *subref = NULL;
    2084             :     int         count;
    2085             : 
    2086         326 :     sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
    2087             : 
    2088         326 :     if (plperl_use_strict)
    2089           2 :         hv_store_string(pragma_hv, "strict", (SV *) newAV());
    2090             : 
    2091         326 :     ENTER;
    2092         326 :     SAVETMPS;
    2093         326 :     PUSHMARK(SP);
    2094         326 :     EXTEND(SP, 4);
    2095         326 :     PUSHs(sv_2mortal(cstr2sv(subname)));
    2096         326 :     PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
    2097             : 
    2098             :     /*
    2099             :      * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
    2100             :      * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
    2101             :      * compiler.
    2102             :      */
    2103         326 :     PUSHs(&PL_sv_no);
    2104         326 :     PUSHs(sv_2mortal(cstr2sv(s)));
    2105         326 :     PUTBACK;
    2106             : 
    2107             :     /*
    2108             :      * G_KEEPERR seems to be needed here, else we don't recognize compile
    2109             :      * errors properly.  Perhaps it's because there's another level of eval
    2110             :      * inside mksafefunc?
    2111             :      */
    2112         326 :     count = call_pv("PostgreSQL::InServer::mkfunc",
    2113             :                     G_SCALAR | G_EVAL | G_KEEPERR);
    2114         326 :     SPAGAIN;
    2115             : 
    2116         326 :     if (count == 1)
    2117             :     {
    2118         326 :         SV         *sub_rv = (SV *) POPs;
    2119             : 
    2120         326 :         if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
    2121             :         {
    2122         310 :             subref = newRV_inc(SvRV(sub_rv));
    2123             :         }
    2124             :     }
    2125             : 
    2126         326 :     PUTBACK;
    2127         326 :     FREETMPS;
    2128         326 :     LEAVE;
    2129             : 
    2130         326 :     if (SvTRUE(ERRSV))
    2131          16 :         ereport(ERROR,
    2132             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    2133             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2134             : 
    2135         310 :     if (!subref)
    2136           0 :         ereport(ERROR,
    2137             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    2138             :                  errmsg("didn't get a CODE reference from compiling function \"%s\"",
    2139             :                         prodesc->proname)));
    2140             : 
    2141         310 :     prodesc->reference = subref;
    2142         310 : }
    2143             : 
    2144             : 
    2145             : /**********************************************************************
    2146             :  * plperl_init_shared_libs()        -
    2147             :  **********************************************************************/
    2148             : 
    2149             : static void
    2150          44 : plperl_init_shared_libs(pTHX)
    2151             : {
    2152          44 :     char       *file = __FILE__;
    2153             : 
    2154          44 :     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    2155          44 :     newXS("PostgreSQL::InServer::Util::bootstrap",
    2156             :           boot_PostgreSQL__InServer__Util, file);
    2157             :     /* newXS for...::SPI::bootstrap is in select_perl_context() */
    2158          44 : }
    2159             : 
    2160             : 
    2161             : static SV  *
    2162         478 : plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
    2163             : {
    2164         478 :     dTHX;
    2165         478 :     dSP;
    2166             :     SV         *retval;
    2167             :     int         i;
    2168             :     int         count;
    2169         478 :     Oid        *argtypes = NULL;
    2170         478 :     int         nargs = 0;
    2171             : 
    2172         478 :     ENTER;
    2173         478 :     SAVETMPS;
    2174             : 
    2175         478 :     PUSHMARK(SP);
    2176         478 :     EXTEND(sp, desc->nargs);
    2177             : 
    2178             :     /* Get signature for true functions; inline blocks have no args. */
    2179         478 :     if (fcinfo->flinfo->fn_oid)
    2180         454 :         get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs);
    2181             :     Assert(nargs == desc->nargs);
    2182             : 
    2183         862 :     for (i = 0; i < desc->nargs; i++)
    2184             :     {
    2185         384 :         if (fcinfo->args[i].isnull)
    2186           8 :             PUSHs(&PL_sv_undef);
    2187         376 :         else if (desc->arg_is_rowtype[i])
    2188             :         {
    2189          22 :             SV         *sv = plperl_hash_from_datum(fcinfo->args[i].value);
    2190             : 
    2191          22 :             PUSHs(sv_2mortal(sv));
    2192             :         }
    2193             :         else
    2194             :         {
    2195             :             SV         *sv;
    2196             :             Oid         funcid;
    2197             : 
    2198         354 :             if (OidIsValid(desc->arg_arraytype[i]))
    2199          26 :                 sv = plperl_ref_from_pg_array(fcinfo->args[i].value, desc->arg_arraytype[i]);
    2200         328 :             else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
    2201         114 :                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->args[i].value));
    2202             :             else
    2203             :             {
    2204             :                 char       *tmp;
    2205             : 
    2206         214 :                 tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
    2207             :                                          fcinfo->args[i].value);
    2208         214 :                 sv = cstr2sv(tmp);
    2209         214 :                 pfree(tmp);
    2210             :             }
    2211             : 
    2212         354 :             PUSHs(sv_2mortal(sv));
    2213             :         }
    2214             :     }
    2215         478 :     PUTBACK;
    2216             : 
    2217             :     /* Do NOT use G_KEEPERR here */
    2218         478 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2219             : 
    2220         476 :     SPAGAIN;
    2221             : 
    2222         476 :     if (count != 1)
    2223             :     {
    2224           0 :         PUTBACK;
    2225           0 :         FREETMPS;
    2226           0 :         LEAVE;
    2227           0 :         ereport(ERROR,
    2228             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2229             :                  errmsg("didn't get a return item from function")));
    2230             :     }
    2231             : 
    2232         476 :     if (SvTRUE(ERRSV))
    2233             :     {
    2234          34 :         (void) POPs;
    2235          34 :         PUTBACK;
    2236          34 :         FREETMPS;
    2237          34 :         LEAVE;
    2238             :         /* XXX need to find a way to determine a better errcode here */
    2239          34 :         ereport(ERROR,
    2240             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2241             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2242             :     }
    2243             : 
    2244         442 :     retval = newSVsv(POPs);
    2245             : 
    2246         442 :     PUTBACK;
    2247         442 :     FREETMPS;
    2248         442 :     LEAVE;
    2249             : 
    2250         442 :     return retval;
    2251             : }
    2252             : 
    2253             : 
    2254             : static SV  *
    2255          60 : plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
    2256             :                               SV *td)
    2257             : {
    2258          60 :     dTHX;
    2259          60 :     dSP;
    2260             :     SV         *retval,
    2261             :                *TDsv;
    2262             :     int         i,
    2263             :                 count;
    2264          60 :     Trigger    *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
    2265             : 
    2266          60 :     ENTER;
    2267          60 :     SAVETMPS;
    2268             : 
    2269          60 :     TDsv = get_sv("main::_TD", 0);
    2270          60 :     if (!TDsv)
    2271           0 :         ereport(ERROR,
    2272             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2273             :                  errmsg("couldn't fetch $_TD")));
    2274             : 
    2275          60 :     save_item(TDsv);            /* local $_TD */
    2276          60 :     sv_setsv(TDsv, td);
    2277             : 
    2278          60 :     PUSHMARK(sp);
    2279          60 :     EXTEND(sp, tg_trigger->tgnargs);
    2280             : 
    2281          96 :     for (i = 0; i < tg_trigger->tgnargs; i++)
    2282          36 :         PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
    2283          60 :     PUTBACK;
    2284             : 
    2285             :     /* Do NOT use G_KEEPERR here */
    2286          60 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2287             : 
    2288          60 :     SPAGAIN;
    2289             : 
    2290          60 :     if (count != 1)
    2291             :     {
    2292           0 :         PUTBACK;
    2293           0 :         FREETMPS;
    2294           0 :         LEAVE;
    2295           0 :         ereport(ERROR,
    2296             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2297             :                  errmsg("didn't get a return item from trigger function")));
    2298             :     }
    2299             : 
    2300          60 :     if (SvTRUE(ERRSV))
    2301             :     {
    2302           0 :         (void) POPs;
    2303           0 :         PUTBACK;
    2304           0 :         FREETMPS;
    2305           0 :         LEAVE;
    2306             :         /* XXX need to find a way to determine a better errcode here */
    2307           0 :         ereport(ERROR,
    2308             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2309             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2310             :     }
    2311             : 
    2312          60 :     retval = newSVsv(POPs);
    2313             : 
    2314          60 :     PUTBACK;
    2315          60 :     FREETMPS;
    2316          60 :     LEAVE;
    2317             : 
    2318          60 :     return retval;
    2319             : }
    2320             : 
    2321             : 
    2322             : static void
    2323          20 : plperl_call_perl_event_trigger_func(plperl_proc_desc *desc,
    2324             :                                     FunctionCallInfo fcinfo,
    2325             :                                     SV *td)
    2326             : {
    2327          20 :     dTHX;
    2328          20 :     dSP;
    2329             :     SV         *retval,
    2330             :                *TDsv;
    2331             :     int         count;
    2332             : 
    2333          20 :     ENTER;
    2334          20 :     SAVETMPS;
    2335             : 
    2336          20 :     TDsv = get_sv("main::_TD", 0);
    2337          20 :     if (!TDsv)
    2338           0 :         ereport(ERROR,
    2339             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2340             :                  errmsg("couldn't fetch $_TD")));
    2341             : 
    2342          20 :     save_item(TDsv);            /* local $_TD */
    2343          20 :     sv_setsv(TDsv, td);
    2344             : 
    2345          20 :     PUSHMARK(sp);
    2346          20 :     PUTBACK;
    2347             : 
    2348             :     /* Do NOT use G_KEEPERR here */
    2349          20 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2350             : 
    2351          20 :     SPAGAIN;
    2352             : 
    2353          20 :     if (count != 1)
    2354             :     {
    2355           0 :         PUTBACK;
    2356           0 :         FREETMPS;
    2357           0 :         LEAVE;
    2358           0 :         ereport(ERROR,
    2359             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2360             :                  errmsg("didn't get a return item from trigger function")));
    2361             :     }
    2362             : 
    2363          20 :     if (SvTRUE(ERRSV))
    2364             :     {
    2365           0 :         (void) POPs;
    2366           0 :         PUTBACK;
    2367           0 :         FREETMPS;
    2368           0 :         LEAVE;
    2369             :         /* XXX need to find a way to determine a better errcode here */
    2370           0 :         ereport(ERROR,
    2371             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2372             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2373             :     }
    2374             : 
    2375          20 :     retval = newSVsv(POPs);
    2376             :     (void) retval;              /* silence compiler warning */
    2377             : 
    2378          20 :     PUTBACK;
    2379          20 :     FREETMPS;
    2380          20 :     LEAVE;
    2381          20 : }
    2382             : 
    2383             : static Datum
    2384         456 : plperl_func_handler(PG_FUNCTION_ARGS)
    2385             : {
    2386             :     bool        nonatomic;
    2387             :     plperl_proc_desc *prodesc;
    2388             :     SV         *perlret;
    2389         456 :     Datum       retval = 0;
    2390             :     ReturnSetInfo *rsi;
    2391             :     ErrorContextCallback pl_error_context;
    2392             : 
    2393         928 :     nonatomic = fcinfo->context &&
    2394         472 :         IsA(fcinfo->context, CallContext) &&
    2395          16 :         !castNode(CallContext, fcinfo->context)->atomic;
    2396             : 
    2397         456 :     if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT)
    2398           0 :         elog(ERROR, "could not connect to SPI manager");
    2399             : 
    2400         456 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
    2401         454 :     current_call_data->prodesc = prodesc;
    2402         454 :     increment_prodesc_refcount(prodesc);
    2403             : 
    2404             :     /* Set a callback for error reporting */
    2405         454 :     pl_error_context.callback = plperl_exec_callback;
    2406         454 :     pl_error_context.previous = error_context_stack;
    2407         454 :     pl_error_context.arg = prodesc->proname;
    2408         454 :     error_context_stack = &pl_error_context;
    2409             : 
    2410         454 :     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
    2411             : 
    2412         454 :     if (prodesc->fn_retisset)
    2413             :     {
    2414             :         /* Check context before allowing the call to go through */
    2415          86 :         if (!rsi || !IsA(rsi, ReturnSetInfo) ||
    2416          86 :             (rsi->allowedModes & SFRM_Materialize) == 0)
    2417           0 :             ereport(ERROR,
    2418             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2419             :                      errmsg("set-valued function called in context that "
    2420             :                             "cannot accept a set")));
    2421             :     }
    2422             : 
    2423         454 :     activate_interpreter(prodesc->interp);
    2424             : 
    2425         454 :     perlret = plperl_call_perl_func(prodesc, fcinfo);
    2426             : 
    2427             :     /************************************************************
    2428             :      * Disconnect from SPI manager and then create the return
    2429             :      * values datum (if the input function does a palloc for it
    2430             :      * this must not be allocated in the SPI memory context
    2431             :      * because SPI_finish would free it).
    2432             :      ************************************************************/
    2433         426 :     if (SPI_finish() != SPI_OK_FINISH)
    2434           0 :         elog(ERROR, "SPI_finish() failed");
    2435             : 
    2436         426 :     if (prodesc->fn_retisset)
    2437             :     {
    2438             :         SV         *sav;
    2439             : 
    2440             :         /*
    2441             :          * If the Perl function returned an arrayref, we pretend that it
    2442             :          * called return_next() for each element of the array, to handle old
    2443             :          * SRFs that didn't know about return_next(). Any other sort of return
    2444             :          * value is an error, except undef which means return an empty set.
    2445             :          */
    2446          84 :         sav = get_perl_array_ref(perlret);
    2447          84 :         if (sav)
    2448             :         {
    2449          36 :             dTHX;
    2450          36 :             int         i = 0;
    2451          36 :             SV        **svp = 0;
    2452          36 :             AV         *rav = (AV *) SvRV(sav);
    2453             : 
    2454         128 :             while ((svp = av_fetch(rav, i, FALSE)) != NULL)
    2455             :             {
    2456         108 :                 plperl_return_next_internal(*svp);
    2457          92 :                 i++;
    2458             :             }
    2459             :         }
    2460          48 :         else if (SvOK(perlret))
    2461             :         {
    2462           4 :             ereport(ERROR,
    2463             :                     (errcode(ERRCODE_DATATYPE_MISMATCH),
    2464             :                      errmsg("set-returning PL/Perl function must return "
    2465             :                             "reference to array or use return_next")));
    2466             :         }
    2467             : 
    2468          64 :         rsi->returnMode = SFRM_Materialize;
    2469          64 :         if (current_call_data->tuple_store)
    2470             :         {
    2471          52 :             rsi->setResult = current_call_data->tuple_store;
    2472          52 :             rsi->setDesc = current_call_data->ret_tdesc;
    2473             :         }
    2474          64 :         retval = (Datum) 0;
    2475             :     }
    2476         342 :     else if (prodesc->result_oid)
    2477             :     {
    2478         342 :         retval = plperl_sv_to_datum(perlret,
    2479             :                                     prodesc->result_oid,
    2480             :                                     -1,
    2481             :                                     fcinfo,
    2482             :                                     &prodesc->result_in_func,
    2483             :                                     prodesc->result_typioparam,
    2484             :                                     &fcinfo->isnull);
    2485             : 
    2486         318 :         if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
    2487           6 :             rsi->isDone = ExprEndResult;
    2488             :     }
    2489             : 
    2490             :     /* Restore the previous error callback */
    2491         382 :     error_context_stack = pl_error_context.previous;
    2492             : 
    2493         382 :     SvREFCNT_dec_current(perlret);
    2494             : 
    2495         382 :     return retval;
    2496             : }
    2497             : 
    2498             : 
    2499             : static Datum
    2500          60 : plperl_trigger_handler(PG_FUNCTION_ARGS)
    2501             : {
    2502             :     plperl_proc_desc *prodesc;
    2503             :     SV         *perlret;
    2504             :     Datum       retval;
    2505             :     SV         *svTD;
    2506             :     HV         *hvTD;
    2507             :     ErrorContextCallback pl_error_context;
    2508             :     TriggerData *tdata;
    2509             :     int         rc PG_USED_FOR_ASSERTS_ONLY;
    2510             : 
    2511             :     /* Connect to SPI manager */
    2512          60 :     if (SPI_connect() != SPI_OK_CONNECT)
    2513           0 :         elog(ERROR, "could not connect to SPI manager");
    2514             : 
    2515             :     /* Make transition tables visible to this SPI connection */
    2516          60 :     tdata = (TriggerData *) fcinfo->context;
    2517          60 :     rc = SPI_register_trigger_data(tdata);
    2518             :     Assert(rc >= 0);
    2519             : 
    2520             :     /* Find or compile the function */
    2521          60 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
    2522          60 :     current_call_data->prodesc = prodesc;
    2523          60 :     increment_prodesc_refcount(prodesc);
    2524             : 
    2525             :     /* Set a callback for error reporting */
    2526          60 :     pl_error_context.callback = plperl_exec_callback;
    2527          60 :     pl_error_context.previous = error_context_stack;
    2528          60 :     pl_error_context.arg = prodesc->proname;
    2529          60 :     error_context_stack = &pl_error_context;
    2530             : 
    2531          60 :     activate_interpreter(prodesc->interp);
    2532             : 
    2533          60 :     svTD = plperl_trigger_build_args(fcinfo);
    2534          60 :     perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
    2535          60 :     hvTD = (HV *) SvRV(svTD);
    2536             : 
    2537             :     /************************************************************
    2538             :     * Disconnect from SPI manager and then create the return
    2539             :     * values datum (if the input function does a palloc for it
    2540             :     * this must not be allocated in the SPI memory context
    2541             :     * because SPI_finish would free it).
    2542             :     ************************************************************/
    2543          60 :     if (SPI_finish() != SPI_OK_FINISH)
    2544           0 :         elog(ERROR, "SPI_finish() failed");
    2545             : 
    2546          60 :     if (perlret == NULL || !SvOK(perlret))
    2547          42 :     {
    2548             :         /* undef result means go ahead with original tuple */
    2549          42 :         TriggerData *trigdata = ((TriggerData *) fcinfo->context);
    2550             : 
    2551          42 :         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    2552          14 :             retval = (Datum) trigdata->tg_trigtuple;
    2553          28 :         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    2554          10 :             retval = (Datum) trigdata->tg_newtuple;
    2555          18 :         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
    2556          18 :             retval = (Datum) trigdata->tg_trigtuple;
    2557           0 :         else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
    2558           0 :             retval = (Datum) trigdata->tg_trigtuple;
    2559             :         else
    2560           0 :             retval = (Datum) 0; /* can this happen? */
    2561             :     }
    2562             :     else
    2563             :     {
    2564             :         HeapTuple   trv;
    2565             :         char       *tmp;
    2566             : 
    2567          18 :         tmp = sv2cstr(perlret);
    2568             : 
    2569          18 :         if (pg_strcasecmp(tmp, "SKIP") == 0)
    2570           6 :             trv = NULL;
    2571          12 :         else if (pg_strcasecmp(tmp, "MODIFY") == 0)
    2572             :         {
    2573          12 :             TriggerData *trigdata = (TriggerData *) fcinfo->context;
    2574             : 
    2575          12 :             if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    2576           8 :                 trv = plperl_modify_tuple(hvTD, trigdata,
    2577             :                                           trigdata->tg_trigtuple);
    2578           4 :             else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    2579           4 :                 trv = plperl_modify_tuple(hvTD, trigdata,
    2580             :                                           trigdata->tg_newtuple);
    2581             :             else
    2582             :             {
    2583           0 :                 ereport(WARNING,
    2584             :                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    2585             :                          errmsg("ignoring modified row in DELETE trigger")));
    2586           0 :                 trv = NULL;
    2587             :             }
    2588             :         }
    2589             :         else
    2590             :         {
    2591           0 :             ereport(ERROR,
    2592             :                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    2593             :                      errmsg("result of PL/Perl trigger function must be undef, "
    2594             :                             "\"SKIP\", or \"MODIFY\"")));
    2595             :             trv = NULL;
    2596             :         }
    2597          16 :         retval = PointerGetDatum(trv);
    2598          16 :         pfree(tmp);
    2599             :     }
    2600             : 
    2601             :     /* Restore the previous error callback */
    2602          58 :     error_context_stack = pl_error_context.previous;
    2603             : 
    2604          58 :     SvREFCNT_dec_current(svTD);
    2605          58 :     if (perlret)
    2606          58 :         SvREFCNT_dec_current(perlret);
    2607             : 
    2608          58 :     return retval;
    2609             : }
    2610             : 
    2611             : 
    2612             : static void
    2613          20 : plperl_event_trigger_handler(PG_FUNCTION_ARGS)
    2614             : {
    2615             :     plperl_proc_desc *prodesc;
    2616             :     SV         *svTD;
    2617             :     ErrorContextCallback pl_error_context;
    2618             : 
    2619             :     /* Connect to SPI manager */
    2620          20 :     if (SPI_connect() != SPI_OK_CONNECT)
    2621           0 :         elog(ERROR, "could not connect to SPI manager");
    2622             : 
    2623             :     /* Find or compile the function */
    2624          20 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
    2625          20 :     current_call_data->prodesc = prodesc;
    2626          20 :     increment_prodesc_refcount(prodesc);
    2627             : 
    2628             :     /* Set a callback for error reporting */
    2629          20 :     pl_error_context.callback = plperl_exec_callback;
    2630          20 :     pl_error_context.previous = error_context_stack;
    2631          20 :     pl_error_context.arg = prodesc->proname;
    2632          20 :     error_context_stack = &pl_error_context;
    2633             : 
    2634          20 :     activate_interpreter(prodesc->interp);
    2635             : 
    2636          20 :     svTD = plperl_event_trigger_build_args(fcinfo);
    2637          20 :     plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
    2638             : 
    2639          20 :     if (SPI_finish() != SPI_OK_FINISH)
    2640           0 :         elog(ERROR, "SPI_finish() failed");
    2641             : 
    2642             :     /* Restore the previous error callback */
    2643          20 :     error_context_stack = pl_error_context.previous;
    2644             : 
    2645          20 :     SvREFCNT_dec_current(svTD);
    2646          20 : }
    2647             : 
    2648             : 
    2649             : static bool
    2650        1222 : validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
    2651             : {
    2652        1222 :     if (proc_ptr && proc_ptr->proc_ptr)
    2653             :     {
    2654         580 :         plperl_proc_desc *prodesc = proc_ptr->proc_ptr;
    2655             :         bool        uptodate;
    2656             : 
    2657             :         /************************************************************
    2658             :          * If it's present, must check whether it's still up to date.
    2659             :          * This is needed because CREATE OR REPLACE FUNCTION can modify the
    2660             :          * function's pg_proc entry without changing its OID.
    2661             :          ************************************************************/
    2662        1114 :         uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
    2663         534 :                     ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
    2664             : 
    2665         580 :         if (uptodate)
    2666         534 :             return true;
    2667             : 
    2668             :         /* Otherwise, unlink the obsoleted entry from the hashtable ... */
    2669          46 :         proc_ptr->proc_ptr = NULL;
    2670             :         /* ... and release the corresponding refcount, probably deleting it */
    2671          46 :         decrement_prodesc_refcount(prodesc);
    2672             :     }
    2673             : 
    2674         688 :     return false;
    2675             : }
    2676             : 
    2677             : 
    2678             : static void
    2679          46 : free_plperl_function(plperl_proc_desc *prodesc)
    2680             : {
    2681             :     Assert(prodesc->fn_refcount == 0);
    2682             :     /* Release CODE reference, if we have one, from the appropriate interp */
    2683          46 :     if (prodesc->reference)
    2684             :     {
    2685          46 :         plperl_interp_desc *oldinterp = plperl_active_interp;
    2686             : 
    2687          46 :         activate_interpreter(prodesc->interp);
    2688          46 :         SvREFCNT_dec_current(prodesc->reference);
    2689          46 :         activate_interpreter(oldinterp);
    2690             :     }
    2691             :     /* Release all PG-owned data for this proc */
    2692          46 :     MemoryContextDelete(prodesc->fn_cxt);
    2693          46 : }
    2694             : 
    2695             : 
    2696             : static plperl_proc_desc *
    2697         828 : compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
    2698             : {
    2699             :     HeapTuple   procTup;
    2700             :     Form_pg_proc procStruct;
    2701             :     plperl_proc_key proc_key;
    2702             :     plperl_proc_ptr *proc_ptr;
    2703         828 :     plperl_proc_desc *volatile prodesc = NULL;
    2704         828 :     volatile MemoryContext proc_cxt = NULL;
    2705         828 :     plperl_interp_desc *oldinterp = plperl_active_interp;
    2706             :     ErrorContextCallback plperl_error_context;
    2707             : 
    2708             :     /* We'll need the pg_proc tuple in any case... */
    2709         828 :     procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
    2710         828 :     if (!HeapTupleIsValid(procTup))
    2711           0 :         elog(ERROR, "cache lookup failed for function %u", fn_oid);
    2712         828 :     procStruct = (Form_pg_proc) GETSTRUCT(procTup);
    2713             : 
    2714             :     /*
    2715             :      * Try to find function in plperl_proc_hash.  The reason for this
    2716             :      * overcomplicated-seeming lookup procedure is that we don't know whether
    2717             :      * it's plperl or plperlu, and don't want to spend a lookup in pg_language
    2718             :      * to find out.
    2719             :      */
    2720         828 :     proc_key.proc_id = fn_oid;
    2721         828 :     proc_key.is_trigger = is_trigger;
    2722         828 :     proc_key.user_id = GetUserId();
    2723         828 :     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2724             :                            HASH_FIND, NULL);
    2725         828 :     if (validate_plperl_function(proc_ptr, procTup))
    2726             :     {
    2727             :         /* Found valid plperl entry */
    2728         434 :         ReleaseSysCache(procTup);
    2729         434 :         return proc_ptr->proc_ptr;
    2730             :     }
    2731             : 
    2732             :     /* If not found or obsolete, maybe it's plperlu */
    2733         394 :     proc_key.user_id = InvalidOid;
    2734         394 :     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2735             :                            HASH_FIND, NULL);
    2736         394 :     if (validate_plperl_function(proc_ptr, procTup))
    2737             :     {
    2738             :         /* Found valid plperlu entry */
    2739         100 :         ReleaseSysCache(procTup);
    2740         100 :         return proc_ptr->proc_ptr;
    2741             :     }
    2742             : 
    2743             :     /************************************************************
    2744             :      * If we haven't found it in the hashtable, we analyze
    2745             :      * the function's arguments and return type and store
    2746             :      * the in-/out-functions in the prodesc block,
    2747             :      * then we load the procedure into the Perl interpreter,
    2748             :      * and last we create a new hashtable entry for it.
    2749             :      ************************************************************/
    2750             : 
    2751             :     /* Set a callback for reporting compilation errors */
    2752         294 :     plperl_error_context.callback = plperl_compile_callback;
    2753         294 :     plperl_error_context.previous = error_context_stack;
    2754         294 :     plperl_error_context.arg = NameStr(procStruct->proname);
    2755         294 :     error_context_stack = &plperl_error_context;
    2756             : 
    2757         294 :     PG_TRY();
    2758             :     {
    2759             :         HeapTuple   langTup;
    2760             :         HeapTuple   typeTup;
    2761             :         Form_pg_language langStruct;
    2762             :         Form_pg_type typeStruct;
    2763             :         Datum       protrftypes_datum;
    2764             :         Datum       prosrcdatum;
    2765             :         bool        isnull;
    2766             :         char       *proc_source;
    2767             :         MemoryContext oldcontext;
    2768             : 
    2769             :         /************************************************************
    2770             :          * Allocate a context that will hold all PG data for the procedure.
    2771             :          ************************************************************/
    2772         294 :         proc_cxt = AllocSetContextCreate(TopMemoryContext,
    2773             :                                          "PL/Perl function",
    2774             :                                          ALLOCSET_SMALL_SIZES);
    2775             : 
    2776             :         /************************************************************
    2777             :          * Allocate and fill a new procedure description block.
    2778             :          * struct prodesc and subsidiary data must all live in proc_cxt.
    2779             :          ************************************************************/
    2780         294 :         oldcontext = MemoryContextSwitchTo(proc_cxt);
    2781         294 :         prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc));
    2782         294 :         prodesc->proname = pstrdup(NameStr(procStruct->proname));
    2783         294 :         MemoryContextSetIdentifier(proc_cxt, prodesc->proname);
    2784         294 :         prodesc->fn_cxt = proc_cxt;
    2785         294 :         prodesc->fn_refcount = 0;
    2786         294 :         prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
    2787         294 :         prodesc->fn_tid = procTup->t_self;
    2788         294 :         prodesc->nargs = procStruct->pronargs;
    2789         294 :         prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
    2790         294 :         prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
    2791         294 :         prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid));
    2792         294 :         MemoryContextSwitchTo(oldcontext);
    2793             : 
    2794             :         /* Remember if function is STABLE/IMMUTABLE */
    2795         294 :         prodesc->fn_readonly =
    2796         294 :             (procStruct->provolatile != PROVOLATILE_VOLATILE);
    2797             : 
    2798             :         /* Fetch protrftypes */
    2799         294 :         protrftypes_datum = SysCacheGetAttr(PROCOID, procTup,
    2800             :                                             Anum_pg_proc_protrftypes, &isnull);
    2801         294 :         MemoryContextSwitchTo(proc_cxt);
    2802         294 :         prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum);
    2803         294 :         MemoryContextSwitchTo(oldcontext);
    2804             : 
    2805             :         /************************************************************
    2806             :          * Lookup the pg_language tuple by Oid
    2807             :          ************************************************************/
    2808         588 :         langTup = SearchSysCache1(LANGOID,
    2809         294 :                                   ObjectIdGetDatum(procStruct->prolang));
    2810         294 :         if (!HeapTupleIsValid(langTup))
    2811           0 :             elog(ERROR, "cache lookup failed for language %u",
    2812             :                  procStruct->prolang);
    2813         294 :         langStruct = (Form_pg_language) GETSTRUCT(langTup);
    2814         294 :         prodesc->lang_oid = langStruct->oid;
    2815         294 :         prodesc->lanpltrusted = langStruct->lanpltrusted;
    2816         294 :         ReleaseSysCache(langTup);
    2817             : 
    2818             :         /************************************************************
    2819             :          * Get the required information for input conversion of the
    2820             :          * return value.
    2821             :          ************************************************************/
    2822         294 :         if (!is_trigger && !is_event_trigger)
    2823             :         {
    2824         276 :             Oid         rettype = procStruct->prorettype;
    2825             : 
    2826         276 :             typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
    2827         276 :             if (!HeapTupleIsValid(typeTup))
    2828           0 :                 elog(ERROR, "cache lookup failed for type %u", rettype);
    2829         276 :             typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    2830             : 
    2831             :             /* Disallow pseudotype result, except VOID or RECORD */
    2832         276 :             if (typeStruct->typtype == TYPTYPE_PSEUDO)
    2833             :             {
    2834          60 :                 if (rettype == VOIDOID ||
    2835             :                     rettype == RECORDOID)
    2836             :                      /* okay */ ;
    2837           2 :                 else if (rettype == TRIGGEROID ||
    2838             :                          rettype == EVENT_TRIGGEROID)
    2839           2 :                     ereport(ERROR,
    2840             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2841             :                              errmsg("trigger functions can only be called "
    2842             :                                     "as triggers")));
    2843             :                 else
    2844           0 :                     ereport(ERROR,
    2845             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2846             :                              errmsg("PL/Perl functions cannot return type %s",
    2847             :                                     format_type_be(rettype))));
    2848             :             }
    2849             : 
    2850         274 :             prodesc->result_oid = rettype;
    2851         274 :             prodesc->fn_retisset = procStruct->proretset;
    2852         274 :             prodesc->fn_retistuple = type_is_rowtype(rettype);
    2853         274 :             prodesc->fn_retisarray = IsTrueArrayType(typeStruct);
    2854             : 
    2855         274 :             fmgr_info_cxt(typeStruct->typinput,
    2856         274 :                           &(prodesc->result_in_func),
    2857             :                           proc_cxt);
    2858         274 :             prodesc->result_typioparam = getTypeIOParam(typeTup);
    2859             : 
    2860         274 :             ReleaseSysCache(typeTup);
    2861             :         }
    2862             : 
    2863             :         /************************************************************
    2864             :          * Get the required information for output conversion
    2865             :          * of all procedure arguments
    2866             :          ************************************************************/
    2867         292 :         if (!is_trigger && !is_event_trigger)
    2868             :         {
    2869             :             int         i;
    2870             : 
    2871         404 :             for (i = 0; i < prodesc->nargs; i++)
    2872             :             {
    2873         130 :                 Oid         argtype = procStruct->proargtypes.values[i];
    2874             : 
    2875         130 :                 typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
    2876         130 :                 if (!HeapTupleIsValid(typeTup))
    2877           0 :                     elog(ERROR, "cache lookup failed for type %u", argtype);
    2878         130 :                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    2879             : 
    2880             :                 /* Disallow pseudotype argument, except RECORD */
    2881         130 :                 if (typeStruct->typtype == TYPTYPE_PSEUDO &&
    2882             :                     argtype != RECORDOID)
    2883           0 :                     ereport(ERROR,
    2884             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2885             :                              errmsg("PL/Perl functions cannot accept type %s",
    2886             :                                     format_type_be(argtype))));
    2887             : 
    2888         130 :                 if (type_is_rowtype(argtype))
    2889          12 :                     prodesc->arg_is_rowtype[i] = true;
    2890             :                 else
    2891             :                 {
    2892         118 :                     prodesc->arg_is_rowtype[i] = false;
    2893         118 :                     fmgr_info_cxt(typeStruct->typoutput,
    2894         118 :                                   &(prodesc->arg_out_func[i]),
    2895             :                                   proc_cxt);
    2896             :                 }
    2897             : 
    2898             :                 /* Identify array-type arguments */
    2899         130 :                 if (IsTrueArrayType(typeStruct))
    2900          14 :                     prodesc->arg_arraytype[i] = argtype;
    2901             :                 else
    2902         116 :                     prodesc->arg_arraytype[i] = InvalidOid;
    2903             : 
    2904         130 :                 ReleaseSysCache(typeTup);
    2905             :             }
    2906             :         }
    2907             : 
    2908             :         /************************************************************
    2909             :          * create the text of the anonymous subroutine.
    2910             :          * we do not use a named subroutine so that we can call directly
    2911             :          * through the reference.
    2912             :          ************************************************************/
    2913         292 :         prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
    2914             :                                       Anum_pg_proc_prosrc, &isnull);
    2915         292 :         if (isnull)
    2916           0 :             elog(ERROR, "null prosrc");
    2917         292 :         proc_source = TextDatumGetCString(prosrcdatum);
    2918             : 
    2919             :         /************************************************************
    2920             :          * Create the procedure in the appropriate interpreter
    2921             :          ************************************************************/
    2922             : 
    2923         292 :         select_perl_context(prodesc->lanpltrusted);
    2924             : 
    2925         292 :         prodesc->interp = plperl_active_interp;
    2926             : 
    2927         292 :         plperl_create_sub(prodesc, proc_source, fn_oid);
    2928             : 
    2929         286 :         activate_interpreter(oldinterp);
    2930             : 
    2931         286 :         pfree(proc_source);
    2932             : 
    2933         286 :         if (!prodesc->reference) /* can this happen? */
    2934           0 :             elog(ERROR, "could not create PL/Perl internal procedure");
    2935             : 
    2936             :         /************************************************************
    2937             :          * OK, link the procedure into the correct hashtable entry.
    2938             :          * Note we assume that the hashtable entry either doesn't exist yet,
    2939             :          * or we already cleared its proc_ptr during the validation attempts
    2940             :          * above.  So no need to decrement an old refcount here.
    2941             :          ************************************************************/
    2942         286 :         proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
    2943             : 
    2944         286 :         proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2945             :                                HASH_ENTER, NULL);
    2946             :         /* We assume these two steps can't throw an error: */
    2947         286 :         proc_ptr->proc_ptr = prodesc;
    2948         286 :         increment_prodesc_refcount(prodesc);
    2949             :     }
    2950           8 :     PG_CATCH();
    2951             :     {
    2952             :         /*
    2953             :          * If we got as far as creating a reference, we should be able to use
    2954             :          * free_plperl_function() to clean up.  If not, then at most we have
    2955             :          * some PG memory resources in proc_cxt, which we can just delete.
    2956             :          */
    2957           8 :         if (prodesc && prodesc->reference)
    2958           0 :             free_plperl_function(prodesc);
    2959           8 :         else if (proc_cxt)
    2960           8 :             MemoryContextDelete(proc_cxt);
    2961             : 
    2962             :         /* Be sure to restore the previous interpreter, too, for luck */
    2963           8 :         activate_interpreter(oldinterp);
    2964             : 
    2965           8 :         PG_RE_THROW();
    2966             :     }
    2967         286 :     PG_END_TRY();
    2968             : 
    2969             :     /* restore previous error callback */
    2970         286 :     error_context_stack = plperl_error_context.previous;
    2971             : 
    2972         286 :     ReleaseSysCache(procTup);
    2973             : 
    2974         286 :     return prodesc;
    2975             : }
    2976             : 
    2977             : /* Build a hash from a given composite/row datum */
    2978             : static SV  *
    2979         114 : plperl_hash_from_datum(Datum attr)
    2980             : {
    2981             :     HeapTupleHeader td;
    2982             :     Oid         tupType;
    2983             :     int32       tupTypmod;
    2984             :     TupleDesc   tupdesc;
    2985             :     HeapTupleData tmptup;
    2986             :     SV         *sv;
    2987             : 
    2988         114 :     td = DatumGetHeapTupleHeader(attr);
    2989             : 
    2990             :     /* Extract rowtype info and find a tupdesc */
    2991         114 :     tupType = HeapTupleHeaderGetTypeId(td);
    2992         114 :     tupTypmod = HeapTupleHeaderGetTypMod(td);
    2993         114 :     tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
    2994             : 
    2995             :     /* Build a temporary HeapTuple control structure */
    2996         114 :     tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
    2997         114 :     tmptup.t_data = td;
    2998             : 
    2999         114 :     sv = plperl_hash_from_tuple(&tmptup, tupdesc, true);
    3000         114 :     ReleaseTupleDesc(tupdesc);
    3001             : 
    3002         114 :     return sv;
    3003             : }
    3004             : 
    3005             : /* Build a hash from all attributes of a given tuple. */
    3006             : static SV  *
    3007         260 : plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc, bool include_generated)
    3008             : {
    3009         260 :     dTHX;
    3010             :     HV         *hv;
    3011             :     int         i;
    3012             : 
    3013             :     /* since this function recurses, it could be driven to stack overflow */
    3014         260 :     check_stack_depth();
    3015             : 
    3016         260 :     hv = newHV();
    3017         260 :     hv_ksplit(hv, tupdesc->natts);   /* pre-grow the hash */
    3018             : 
    3019         686 :     for (i = 0; i < tupdesc->natts; i++)
    3020             :     {
    3021             :         Datum       attr;
    3022             :         bool        isnull,
    3023             :                     typisvarlena;
    3024             :         char       *attname;
    3025             :         Oid         typoutput;
    3026         426 :         Form_pg_attribute att = TupleDescAttr(tupdesc, i);
    3027             : 
    3028         426 :         if (att->attisdropped)
    3029          20 :             continue;
    3030             : 
    3031         426 :         if (att->attgenerated)
    3032             :         {
    3033             :             /* don't include unless requested */
    3034          18 :             if (!include_generated)
    3035           6 :                 continue;
    3036             :         }
    3037             : 
    3038         420 :         attname = NameStr(att->attname);
    3039         420 :         attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
    3040             : 
    3041         420 :         if (isnull)
    3042             :         {
    3043             :             /*
    3044             :              * Store (attname => undef) and move on.  Note we can't use
    3045             :              * &PL_sv_undef here; see "AVs, HVs and undefined values" in
    3046             :              * perlguts for an explanation.
    3047             :              */
    3048          14 :             hv_store_string(hv, attname, newSV(0));
    3049          14 :             continue;
    3050             :         }
    3051             : 
    3052         406 :         if (type_is_rowtype(att->atttypid))
    3053             :         {
    3054          84 :             SV         *sv = plperl_hash_from_datum(attr);
    3055             : 
    3056          84 :             hv_store_string(hv, attname, sv);
    3057             :         }
    3058             :         else
    3059             :         {
    3060             :             SV         *sv;
    3061             :             Oid         funcid;
    3062             : 
    3063         322 :             if (OidIsValid(get_base_element_type(att->atttypid)))
    3064           8 :                 sv = plperl_ref_from_pg_array(attr, att->atttypid);
    3065         314 :             else if ((funcid = get_transform_fromsql(att->atttypid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
    3066          14 :                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr));
    3067             :             else
    3068             :             {
    3069             :                 char       *outputstr;
    3070             : 
    3071             :                 /* XXX should have a way to cache these lookups */
    3072         300 :                 getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
    3073             : 
    3074         300 :                 outputstr = OidOutputFunctionCall(typoutput, attr);
    3075         300 :                 sv = cstr2sv(outputstr);
    3076         300 :                 pfree(outputstr);
    3077             :             }
    3078             : 
    3079         322 :             hv_store_string(hv, attname, sv);
    3080             :         }
    3081             :     }
    3082         260 :     return newRV_noinc((SV *) hv);
    3083             : }
    3084             : 
    3085             : 
    3086             : static void
    3087         342 : check_spi_usage_allowed(void)
    3088             : {
    3089             :     /* see comment in plperl_fini() */
    3090         342 :     if (plperl_ending)
    3091             :     {
    3092             :         /* simple croak as we don't want to involve PostgreSQL code */
    3093           0 :         croak("SPI functions can not be used in END blocks");
    3094             :     }
    3095         342 : }
    3096             : 
    3097             : 
    3098             : HV *
    3099         104 : plperl_spi_exec(char *query, int limit)
    3100             : {
    3101             :     HV         *ret_hv;
    3102             : 
    3103             :     /*
    3104             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3105             :      * sanely
    3106             :      */
    3107         104 :     MemoryContext oldcontext = CurrentMemoryContext;
    3108         104 :     ResourceOwner oldowner = CurrentResourceOwner;
    3109             : 
    3110         104 :     check_spi_usage_allowed();
    3111             : 
    3112         104 :     BeginInternalSubTransaction(NULL);
    3113             :     /* Want to run inside function's memory context */
    3114         104 :     MemoryContextSwitchTo(oldcontext);
    3115             : 
    3116         104 :     PG_TRY();
    3117             :     {
    3118             :         int         spi_rv;
    3119             : 
    3120         104 :         pg_verifymbstr(query, strlen(query), false);
    3121             : 
    3122         104 :         spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
    3123             :                              limit);
    3124          92 :         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
    3125             :                                                  spi_rv);
    3126             : 
    3127             :         /* Commit the inner transaction, return to outer xact context */
    3128          92 :         ReleaseCurrentSubTransaction();
    3129          92 :         MemoryContextSwitchTo(oldcontext);
    3130          92 :         CurrentResourceOwner = oldowner;
    3131             :     }
    3132          12 :     PG_CATCH();
    3133             :     {
    3134             :         ErrorData  *edata;
    3135             : 
    3136             :         /* Save error info */
    3137          12 :         MemoryContextSwitchTo(oldcontext);
    3138          12 :         edata = CopyErrorData();
    3139          12 :         FlushErrorState();
    3140             : 
    3141             :         /* Abort the inner transaction */
    3142          12 :         RollbackAndReleaseCurrentSubTransaction();
    3143          12 :         MemoryContextSwitchTo(oldcontext);
    3144          12 :         CurrentResourceOwner = oldowner;
    3145             : 
    3146             :         /* Punt the error to Perl */
    3147          12 :         croak_cstr(edata->message);
    3148             : 
    3149             :         /* Can't get here, but keep compiler quiet */
    3150           0 :         return NULL;
    3151             :     }
    3152          92 :     PG_END_TRY();
    3153             : 
    3154          92 :     return ret_hv;
    3155             : }
    3156             : 
    3157             : 
    3158             : static HV  *
    3159         104 : plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
    3160             :                                 int status)
    3161             : {
    3162         104 :     dTHX;
    3163             :     HV         *result;
    3164             : 
    3165         104 :     check_spi_usage_allowed();
    3166             : 
    3167         104 :     result = newHV();
    3168             : 
    3169         104 :     hv_store_string(result, "status",
    3170             :                     cstr2sv(SPI_result_code_string(status)));
    3171         104 :     hv_store_string(result, "processed",
    3172             :                     (processed > (uint64) UV_MAX) ?
    3173             :                     newSVnv((NV) processed) :
    3174             :                     newSVuv((UV) processed));
    3175             : 
    3176         104 :     if (status > 0 && tuptable)
    3177             :     {
    3178             :         AV         *rows;
    3179             :         SV         *row;
    3180             :         uint64      i;
    3181             : 
    3182             :         /* Prevent overflow in call to av_extend() */
    3183          20 :         if (processed > (uint64) AV_SIZE_MAX)
    3184           0 :             ereport(ERROR,
    3185             :                     (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
    3186             :                      errmsg("query result has too many rows to fit in a Perl array")));
    3187             : 
    3188          20 :         rows = newAV();
    3189          20 :         av_extend(rows, processed);
    3190          40 :         for (i = 0; i < processed; i++)
    3191             :         {
    3192          20 :             row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc, true);
    3193          20 :             av_push(rows, row);
    3194             :         }
    3195          20 :         hv_store_string(result, "rows",
    3196             :                         newRV_noinc((SV *) rows));
    3197             :     }
    3198             : 
    3199         104 :     SPI_freetuptable(tuptable);
    3200             : 
    3201         104 :     return result;
    3202             : }
    3203             : 
    3204             : 
    3205             : /*
    3206             :  * plperl_return_next catches any error and converts it to a Perl error.
    3207             :  * We assume (perhaps without adequate justification) that we need not abort
    3208             :  * the current transaction if the Perl code traps the error.
    3209             :  */
    3210             : void
    3211         174 : plperl_return_next(SV *sv)
    3212             : {
    3213         174 :     MemoryContext oldcontext = CurrentMemoryContext;
    3214             : 
    3215         174 :     PG_TRY();
    3216             :     {
    3217         174 :         plperl_return_next_internal(sv);
    3218             :     }
    3219           0 :     PG_CATCH();
    3220             :     {
    3221             :         ErrorData  *edata;
    3222             : 
    3223             :         /* Must reset elog.c's state */
    3224           0 :         MemoryContextSwitchTo(oldcontext);
    3225           0 :         edata = CopyErrorData();
    3226           0 :         FlushErrorState();
    3227             : 
    3228             :         /* Punt the error to Perl */
    3229           0 :         croak_cstr(edata->message);
    3230             :     }
    3231         174 :     PG_END_TRY();
    3232         174 : }
    3233             : 
    3234             : /*
    3235             :  * plperl_return_next_internal reports any errors in Postgres fashion
    3236             :  * (via ereport).
    3237             :  */
    3238             : static void
    3239         282 : plperl_return_next_internal(SV *sv)
    3240             : {
    3241             :     plperl_proc_desc *prodesc;
    3242             :     FunctionCallInfo fcinfo;
    3243             :     ReturnSetInfo *rsi;
    3244             :     MemoryContext old_cxt;
    3245             : 
    3246         282 :     if (!sv)
    3247           0 :         return;
    3248             : 
    3249         282 :     prodesc = current_call_data->prodesc;
    3250         282 :     fcinfo = current_call_data->fcinfo;
    3251         282 :     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
    3252             : 
    3253         282 :     if (!prodesc->fn_retisset)
    3254           0 :         ereport(ERROR,
    3255             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    3256             :                  errmsg("cannot use return_next in a non-SETOF function")));
    3257             : 
    3258         282 :     if (!current_call_data->ret_tdesc)
    3259             :     {
    3260             :         TupleDesc   tupdesc;
    3261             : 
    3262             :         Assert(!current_call_data->tuple_store);
    3263             : 
    3264             :         /*
    3265             :          * This is the first call to return_next in the current PL/Perl
    3266             :          * function call, so identify the output tuple type and create a
    3267             :          * tuplestore to hold the result rows.
    3268             :          */
    3269          68 :         if (prodesc->fn_retistuple)
    3270             :         {
    3271             :             TypeFuncClass funcclass;
    3272             :             Oid         typid;
    3273             : 
    3274          34 :             funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
    3275          34 :             if (funcclass != TYPEFUNC_COMPOSITE &&
    3276             :                 funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
    3277           4 :                 ereport(ERROR,
    3278             :                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    3279             :                          errmsg("function returning record called in context "
    3280             :                                 "that cannot accept type record")));
    3281             :             /* if domain-over-composite, remember the domain's type OID */
    3282          30 :             if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
    3283           4 :                 current_call_data->cdomain_oid = typid;
    3284             :         }
    3285             :         else
    3286             :         {
    3287          34 :             tupdesc = rsi->expectedDesc;
    3288             :             /* Protect assumption below that we return exactly one column */
    3289          34 :             if (tupdesc == NULL || tupdesc->natts != 1)
    3290           0 :                 elog(ERROR, "expected single-column result descriptor for non-composite SETOF result");
    3291             :         }
    3292             : 
    3293             :         /*
    3294             :          * Make sure the tuple_store and ret_tdesc are sufficiently
    3295             :          * long-lived.
    3296             :          */
    3297          64 :         old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
    3298             : 
    3299          64 :         current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
    3300         128 :         current_call_data->tuple_store =
    3301          64 :             tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
    3302             :                                   false, work_mem);
    3303             : 
    3304          64 :         MemoryContextSwitchTo(old_cxt);
    3305             :     }
    3306             : 
    3307             :     /*
    3308             :      * Producing the tuple we want to return requires making plenty of
    3309             :      * palloc() allocations that are not cleaned up. Since this function can
    3310             :      * be called many times before the current memory context is reset, we
    3311             :      * need to do those allocations in a temporary context.
    3312             :      */
    3313         278 :     if (!current_call_data->tmp_cxt)
    3314             :     {
    3315          64 :         current_call_data->tmp_cxt =
    3316          64 :             AllocSetContextCreate(CurrentMemoryContext,
    3317             :                                   "PL/Perl return_next temporary cxt",
    3318             :                                   ALLOCSET_DEFAULT_SIZES);
    3319             :     }
    3320             : 
    3321         278 :     old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
    3322             : 
    3323         278 :     if (prodesc->fn_retistuple)
    3324             :     {
    3325             :         HeapTuple   tuple;
    3326             : 
    3327          86 :         if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
    3328           8 :             ereport(ERROR,
    3329             :                     (errcode(ERRCODE_DATATYPE_MISMATCH),
    3330             :                      errmsg("SETOF-composite-returning PL/Perl function "
    3331             :                             "must call return_next with reference to hash")));
    3332             : 
    3333          78 :         tuple = plperl_build_tuple_result((HV *) SvRV(sv),
    3334          78 :                                           current_call_data->ret_tdesc);
    3335             : 
    3336          76 :         if (OidIsValid(current_call_data->cdomain_oid))
    3337           8 :             domain_check(HeapTupleGetDatum(tuple), false,
    3338           8 :                          current_call_data->cdomain_oid,
    3339           8 :                          &current_call_data->cdomain_info,
    3340           8 :                          rsi->econtext->ecxt_per_query_memory);
    3341             : 
    3342          74 :         tuplestore_puttuple(current_call_data->tuple_store, tuple);
    3343             :     }
    3344         192 :     else if (prodesc->result_oid)
    3345             :     {
    3346             :         Datum       ret[1];
    3347             :         bool        isNull[1];
    3348             : 
    3349         192 :         ret[0] = plperl_sv_to_datum(sv,
    3350             :                                     prodesc->result_oid,
    3351             :                                     -1,
    3352             :                                     fcinfo,
    3353             :                                     &prodesc->result_in_func,
    3354             :                                     prodesc->result_typioparam,
    3355             :                                     &isNull[0]);
    3356             : 
    3357         192 :         tuplestore_putvalues(current_call_data->tuple_store,
    3358         192 :                              current_call_data->ret_tdesc,
    3359             :                              ret, isNull);
    3360             :     }
    3361             : 
    3362         266 :     MemoryContextSwitchTo(old_cxt);
    3363         266 :     MemoryContextReset(current_call_data->tmp_cxt);
    3364             : }
    3365             : 
    3366             : 
    3367             : SV *
    3368          18 : plperl_spi_query(char *query)
    3369             : {
    3370             :     SV         *cursor;
    3371             : 
    3372             :     /*
    3373             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3374             :      * sanely
    3375             :      */
    3376          18 :     MemoryContext oldcontext = CurrentMemoryContext;
    3377          18 :     ResourceOwner oldowner = CurrentResourceOwner;
    3378             : 
    3379          18 :     check_spi_usage_allowed();
    3380             : 
    3381          18 :     BeginInternalSubTransaction(NULL);
    3382             :     /* Want to run inside function's memory context */
    3383          18 :     MemoryContextSwitchTo(oldcontext);
    3384             : 
    3385          18 :     PG_TRY();
    3386             :     {
    3387             :         SPIPlanPtr  plan;
    3388             :         Portal      portal;
    3389             : 
    3390             :         /* Make sure the query is validly encoded */
    3391          18 :         pg_verifymbstr(query, strlen(query), false);
    3392             : 
    3393             :         /* Create a cursor for the query */
    3394          18 :         plan = SPI_prepare(query, 0, NULL);
    3395          18 :         if (plan == NULL)
    3396           0 :             elog(ERROR, "SPI_prepare() failed:%s",
    3397             :                  SPI_result_code_string(SPI_result));
    3398             : 
    3399          18 :         portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
    3400          18 :         SPI_freeplan(plan);
    3401          18 :         if (portal == NULL)
    3402           0 :             elog(ERROR, "SPI_cursor_open() failed:%s",
    3403             :                  SPI_result_code_string(SPI_result));
    3404          18 :         cursor = cstr2sv(portal->name);
    3405             : 
    3406          18 :         PinPortal(portal);
    3407             : 
    3408             :         /* Commit the inner transaction, return to outer xact context */
    3409          18 :         ReleaseCurrentSubTransaction();
    3410          18 :         MemoryContextSwitchTo(oldcontext);
    3411          18 :         CurrentResourceOwner = oldowner;
    3412             :     }
    3413           0 :     PG_CATCH();
    3414             :     {
    3415             :         ErrorData  *edata;
    3416             : 
    3417             :         /* Save error info */
    3418           0 :         MemoryContextSwitchTo(oldcontext);
    3419           0 :         edata = CopyErrorData();
    3420           0 :         FlushErrorState();
    3421             : 
    3422             :         /* Abort the inner transaction */
    3423           0 :         RollbackAndReleaseCurrentSubTransaction();
    3424           0 :         MemoryContextSwitchTo(oldcontext);
    3425           0 :         CurrentResourceOwner = oldowner;
    3426             : 
    3427             :         /* Punt the error to Perl */
    3428           0 :         croak_cstr(edata->message);
    3429             : 
    3430             :         /* Can't get here, but keep compiler quiet */
    3431           0 :         return NULL;
    3432             :     }
    3433          18 :     PG_END_TRY();
    3434             : 
    3435          18 :     return cursor;
    3436             : }
    3437             : 
    3438             : 
    3439             : SV *
    3440          72 : plperl_spi_fetchrow(char *cursor)
    3441             : {
    3442             :     SV         *row;
    3443             : 
    3444             :     /*
    3445             :      * Execute the FETCH inside a sub-transaction, so we can cope with errors
    3446             :      * sanely
    3447             :      */
    3448          72 :     MemoryContext oldcontext = CurrentMemoryContext;
    3449          72 :     ResourceOwner oldowner = CurrentResourceOwner;
    3450             : 
    3451          72 :     check_spi_usage_allowed();
    3452             : 
    3453          72 :     BeginInternalSubTransaction(NULL);
    3454             :     /* Want to run inside function's memory context */
    3455          72 :     MemoryContextSwitchTo(oldcontext);
    3456             : 
    3457          72 :     PG_TRY();
    3458             :     {
    3459          72 :         dTHX;
    3460          72 :         Portal      p = SPI_cursor_find(cursor);
    3461             : 
    3462          72 :         if (!p)
    3463             :         {
    3464           0 :             row = &PL_sv_undef;
    3465             :         }
    3466             :         else
    3467             :         {
    3468          72 :             SPI_cursor_fetch(p, true, 1);
    3469          72 :             if (SPI_processed == 0)
    3470             :             {
    3471          18 :                 UnpinPortal(p);
    3472          18 :                 SPI_cursor_close(p);
    3473          18 :                 row = &PL_sv_undef;
    3474             :             }
    3475             :             else
    3476             :             {
    3477          54 :                 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
    3478          54 :                                              SPI_tuptable->tupdesc,
    3479             :                                              true);
    3480             :             }
    3481          72 :             SPI_freetuptable(SPI_tuptable);
    3482             :         }
    3483             : 
    3484             :         /* Commit the inner transaction, return to outer xact context */
    3485          72 :         ReleaseCurrentSubTransaction();
    3486          72 :         MemoryContextSwitchTo(oldcontext);
    3487          72 :         CurrentResourceOwner = oldowner;
    3488             :     }
    3489           0 :     PG_CATCH();
    3490             :     {
    3491             :         ErrorData  *edata;
    3492             : 
    3493             :         /* Save error info */
    3494           0 :         MemoryContextSwitchTo(oldcontext);
    3495           0 :         edata = CopyErrorData();
    3496           0 :         FlushErrorState();
    3497             : 
    3498             :         /* Abort the inner transaction */
    3499           0 :         RollbackAndReleaseCurrentSubTransaction();
    3500           0 :         MemoryContextSwitchTo(oldcontext);
    3501           0 :         CurrentResourceOwner = oldowner;
    3502             : 
    3503             :         /* Punt the error to Perl */
    3504           0 :         croak_cstr(edata->message);
    3505             : 
    3506             :         /* Can't get here, but keep compiler quiet */
    3507           0 :         return NULL;
    3508             :     }
    3509          72 :     PG_END_TRY();
    3510             : 
    3511          72 :     return row;
    3512             : }
    3513             : 
    3514             : void
    3515           2 : plperl_spi_cursor_close(char *cursor)
    3516             : {
    3517             :     Portal      p;
    3518             : 
    3519           2 :     check_spi_usage_allowed();
    3520             : 
    3521           2 :     p = SPI_cursor_find(cursor);
    3522             : 
    3523           2 :     if (p)
    3524             :     {
    3525           2 :         UnpinPortal(p);
    3526           2 :         SPI_cursor_close(p);
    3527             :     }
    3528           2 : }
    3529             : 
    3530             : SV *
    3531          16 : plperl_spi_prepare(char *query, int argc, SV **argv)
    3532             : {
    3533          16 :     volatile SPIPlanPtr plan = NULL;
    3534          16 :     volatile MemoryContext plan_cxt = NULL;
    3535          16 :     plperl_query_desc *volatile qdesc = NULL;
    3536          16 :     plperl_query_entry *volatile hash_entry = NULL;
    3537          16 :     MemoryContext oldcontext = CurrentMemoryContext;
    3538          16 :     ResourceOwner oldowner = CurrentResourceOwner;
    3539             :     MemoryContext work_cxt;
    3540             :     bool        found;
    3541             :     int         i;
    3542             : 
    3543          16 :     check_spi_usage_allowed();
    3544             : 
    3545          16 :     BeginInternalSubTransaction(NULL);
    3546          16 :     MemoryContextSwitchTo(oldcontext);
    3547             : 
    3548          16 :     PG_TRY();
    3549             :     {
    3550          16 :         CHECK_FOR_INTERRUPTS();
    3551             : 
    3552             :         /************************************************************
    3553             :          * Allocate the new querydesc structure
    3554             :          *
    3555             :          * The qdesc struct, as well as all its subsidiary data, lives in its
    3556             :          * plan_cxt.  But note that the SPIPlan does not.
    3557             :          ************************************************************/
    3558          16 :         plan_cxt = AllocSetContextCreate(TopMemoryContext,
    3559             :                                          "PL/Perl spi_prepare query",
    3560             :                                          ALLOCSET_SMALL_SIZES);
    3561          16 :         MemoryContextSwitchTo(plan_cxt);
    3562          16 :         qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc));
    3563          16 :         snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
    3564          16 :         qdesc->plan_cxt = plan_cxt;
    3565          16 :         qdesc->nargs = argc;
    3566          16 :         qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid));
    3567          16 :         qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo));
    3568          16 :         qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid));
    3569          16 :         MemoryContextSwitchTo(oldcontext);
    3570             : 
    3571             :         /************************************************************
    3572             :          * Do the following work in a short-lived context so that we don't
    3573             :          * leak a lot of memory in the PL/Perl function's SPI Proc context.
    3574             :          ************************************************************/
    3575          16 :         work_cxt = AllocSetContextCreate(CurrentMemoryContext,
    3576             :                                          "PL/Perl spi_prepare workspace",
    3577             :                                          ALLOCSET_DEFAULT_SIZES);
    3578          16 :         MemoryContextSwitchTo(work_cxt);
    3579             : 
    3580             :         /************************************************************
    3581             :          * Resolve argument type names and then look them up by oid
    3582             :          * in the system cache, and remember the required information
    3583             :          * for input conversion.
    3584             :          ************************************************************/
    3585          30 :         for (i = 0; i < argc; i++)
    3586             :         {
    3587             :             Oid         typId,
    3588             :                         typInput,
    3589             :                         typIOParam;
    3590             :             int32       typmod;
    3591             :             char       *typstr;
    3592             : 
    3593          16 :             typstr = sv2cstr(argv[i]);
    3594          16 :             parseTypeString(typstr, &typId, &typmod, false);
    3595          14 :             pfree(typstr);
    3596             : 
    3597          14 :             getTypeInputInfo(typId, &typInput, &typIOParam);
    3598             : 
    3599          14 :             qdesc->argtypes[i] = typId;
    3600          14 :             fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
    3601          14 :             qdesc->argtypioparams[i] = typIOParam;
    3602             :         }
    3603             : 
    3604             :         /* Make sure the query is validly encoded */
    3605          14 :         pg_verifymbstr(query, strlen(query), false);
    3606             : 
    3607             :         /************************************************************
    3608             :          * Prepare the plan and check for errors
    3609             :          ************************************************************/
    3610          14 :         plan = SPI_prepare(query, argc, qdesc->argtypes);
    3611             : 
    3612          14 :         if (plan == NULL)
    3613           0 :             elog(ERROR, "SPI_prepare() failed:%s",
    3614             :                  SPI_result_code_string(SPI_result));
    3615             : 
    3616             :         /************************************************************
    3617             :          * Save the plan into permanent memory (right now it's in the
    3618             :          * SPI procCxt, which will go away at function end).
    3619             :          ************************************************************/
    3620          14 :         if (SPI_keepplan(plan))
    3621           0 :             elog(ERROR, "SPI_keepplan() failed");
    3622          14 :         qdesc->plan = plan;
    3623             : 
    3624             :         /************************************************************
    3625             :          * Insert a hashtable entry for the plan.
    3626             :          ************************************************************/
    3627          28 :         hash_entry = hash_search(plperl_active_interp->query_hash,
    3628          14 :                                  qdesc->qname,
    3629             :                                  HASH_ENTER, &found);
    3630          14 :         hash_entry->query_data = qdesc;
    3631             : 
    3632             :         /* Get rid of workspace */
    3633          14 :         MemoryContextDelete(work_cxt);
    3634             : 
    3635             :         /* Commit the inner transaction, return to outer xact context */
    3636          14 :         ReleaseCurrentSubTransaction();
    3637          14 :         MemoryContextSwitchTo(oldcontext);
    3638          14 :         CurrentResourceOwner = oldowner;
    3639             :     }
    3640           2 :     PG_CATCH();
    3641             :     {
    3642             :         ErrorData  *edata;
    3643             : 
    3644             :         /* Save error info */
    3645           2 :         MemoryContextSwitchTo(oldcontext);
    3646           2 :         edata = CopyErrorData();
    3647           2 :         FlushErrorState();
    3648             : 
    3649             :         /* Drop anything we managed to allocate */
    3650           2 :         if (hash_entry)
    3651           0 :             hash_search(plperl_active_interp->query_hash,
    3652           0 :                         qdesc->qname,
    3653             :                         HASH_REMOVE, NULL);
    3654           2 :         if (plan_cxt)
    3655           2 :             MemoryContextDelete(plan_cxt);
    3656           2 :         if (plan)
    3657           0 :             SPI_freeplan(plan);
    3658             : 
    3659             :         /* Abort the inner transaction */
    3660           2 :         RollbackAndReleaseCurrentSubTransaction();
    3661           2 :         MemoryContextSwitchTo(oldcontext);
    3662           2 :         CurrentResourceOwner = oldowner;
    3663             : 
    3664             :         /* Punt the error to Perl */
    3665           2 :         croak_cstr(edata->message);
    3666             : 
    3667             :         /* Can't get here, but keep compiler quiet */
    3668           0 :         return NULL;
    3669             :     }
    3670          14 :     PG_END_TRY();
    3671             : 
    3672             :     /************************************************************
    3673             :      * Return the query's hash key to the caller.
    3674             :      ************************************************************/
    3675          14 :     return cstr2sv(qdesc->qname);
    3676             : }
    3677             : 
    3678             : HV *
    3679          12 : plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
    3680             : {
    3681             :     HV         *ret_hv;
    3682             :     SV        **sv;
    3683             :     int         i,
    3684             :                 limit,
    3685             :                 spi_rv;
    3686             :     char       *nulls;
    3687             :     Datum      *argvalues;
    3688             :     plperl_query_desc *qdesc;
    3689             :     plperl_query_entry *hash_entry;
    3690             : 
    3691             :     /*
    3692             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3693             :      * sanely
    3694             :      */
    3695          12 :     MemoryContext oldcontext = CurrentMemoryContext;
    3696          12 :     ResourceOwner oldowner = CurrentResourceOwner;
    3697             : 
    3698          12 :     check_spi_usage_allowed();
    3699             : 
    3700          12 :     BeginInternalSubTransaction(NULL);
    3701             :     /* Want to run inside function's memory context */
    3702          12 :     MemoryContextSwitchTo(oldcontext);
    3703             : 
    3704          12 :     PG_TRY();
    3705             :     {
    3706          12 :         dTHX;
    3707             : 
    3708             :         /************************************************************
    3709             :          * Fetch the saved plan descriptor, see if it's o.k.
    3710             :          ************************************************************/
    3711          12 :         hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3712             :                                  HASH_FIND, NULL);
    3713          12 :         if (hash_entry == NULL)
    3714           0 :             elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
    3715             : 
    3716          12 :         qdesc = hash_entry->query_data;
    3717          12 :         if (qdesc == NULL)
    3718           0 :             elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished");
    3719             : 
    3720          12 :         if (qdesc->nargs != argc)
    3721           0 :             elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
    3722             :                  qdesc->nargs, argc);
    3723             : 
    3724             :         /************************************************************
    3725             :          * Parse eventual attributes
    3726             :          ************************************************************/
    3727          12 :         limit = 0;
    3728          12 :         if (attr != NULL)
    3729             :         {
    3730           4 :             sv = hv_fetch_string(attr, "limit");
    3731           4 :             if (sv && *sv && SvIOK(*sv))
    3732           0 :                 limit = SvIV(*sv);
    3733             :         }
    3734             :         /************************************************************
    3735             :          * Set up arguments
    3736             :          ************************************************************/
    3737          12 :         if (argc > 0)
    3738             :         {
    3739           8 :             nulls = (char *) palloc(argc);
    3740           8 :             argvalues = (Datum *) palloc(argc * sizeof(Datum));
    3741             :         }
    3742             :         else
    3743             :         {
    3744           4 :             nulls = NULL;
    3745           4 :             argvalues = NULL;
    3746             :         }
    3747             : 
    3748          20 :         for (i = 0; i < argc; i++)
    3749             :         {
    3750             :             bool        isnull;
    3751             : 
    3752          16 :             argvalues[i] = plperl_sv_to_datum(argv[i],
    3753           8 :                                               qdesc->argtypes[i],
    3754             :                                               -1,
    3755             :                                               NULL,
    3756           8 :                                               &qdesc->arginfuncs[i],
    3757           8 :                                               qdesc->argtypioparams[i],
    3758             :                                               &isnull);
    3759           8 :             nulls[i] = isnull ? 'n' : ' ';
    3760             :         }
    3761             : 
    3762             :         /************************************************************
    3763             :          * go
    3764             :          ************************************************************/
    3765          24 :         spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
    3766          12 :                                   current_call_data->prodesc->fn_readonly, limit);
    3767          12 :         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
    3768             :                                                  spi_rv);
    3769          12 :         if (argc > 0)
    3770             :         {
    3771           8 :             pfree(argvalues);
    3772           8 :             pfree(nulls);
    3773             :         }
    3774             : 
    3775             :         /* Commit the inner transaction, return to outer xact context */
    3776          12 :         ReleaseCurrentSubTransaction();
    3777          12 :         MemoryContextSwitchTo(oldcontext);
    3778          12 :         CurrentResourceOwner = oldowner;
    3779             :     }
    3780           0 :     PG_CATCH();
    3781             :     {
    3782             :         ErrorData  *edata;
    3783             : 
    3784             :         /* Save error info */
    3785           0 :         MemoryContextSwitchTo(oldcontext);
    3786           0 :         edata = CopyErrorData();
    3787           0 :         FlushErrorState();
    3788             : 
    3789             :         /* Abort the inner transaction */
    3790           0 :         RollbackAndReleaseCurrentSubTransaction();
    3791           0 :         MemoryContextSwitchTo(oldcontext);
    3792           0 :         CurrentResourceOwner = oldowner;
    3793             : 
    3794             :         /* Punt the error to Perl */
    3795           0 :         croak_cstr(edata->message);
    3796             : 
    3797             :         /* Can't get here, but keep compiler quiet */
    3798           0 :         return NULL;
    3799             :     }
    3800          12 :     PG_END_TRY();
    3801             : 
    3802          12 :     return ret_hv;
    3803             : }
    3804             : 
    3805             : SV *
    3806           4 : plperl_spi_query_prepared(char *query, int argc, SV **argv)
    3807             : {
    3808             :     int         i;
    3809             :     char       *nulls;
    3810             :     Datum      *argvalues;
    3811             :     plperl_query_desc *qdesc;
    3812             :     plperl_query_entry *hash_entry;
    3813             :     SV         *cursor;
    3814           4 :     Portal      portal = NULL;
    3815             : 
    3816             :     /*
    3817             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3818             :      * sanely
    3819             :      */
    3820           4 :     MemoryContext oldcontext = CurrentMemoryContext;
    3821           4 :     ResourceOwner oldowner = CurrentResourceOwner;
    3822             : 
    3823           4 :     check_spi_usage_allowed();
    3824             : 
    3825           4 :     BeginInternalSubTransaction(NULL);
    3826             :     /* Want to run inside function's memory context */
    3827           4 :     MemoryContextSwitchTo(oldcontext);
    3828             : 
    3829           4 :     PG_TRY();
    3830             :     {
    3831             :         /************************************************************
    3832             :          * Fetch the saved plan descriptor, see if it's o.k.
    3833             :          ************************************************************/
    3834           4 :         hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3835             :                                  HASH_FIND, NULL);
    3836           4 :         if (hash_entry == NULL)
    3837           0 :             elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
    3838             : 
    3839           4 :         qdesc = hash_entry->query_data;
    3840           4 :         if (qdesc == NULL)
    3841           0 :             elog(ERROR, "spi_query_prepared: plperl query_hash value vanished");
    3842             : 
    3843           4 :         if (qdesc->nargs != argc)
    3844           0 :             elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
    3845             :                  qdesc->nargs, argc);
    3846             : 
    3847             :         /************************************************************
    3848             :          * Set up arguments
    3849             :          ************************************************************/
    3850           4 :         if (argc > 0)
    3851             :         {
    3852           4 :             nulls = (char *) palloc(argc);
    3853           4 :             argvalues = (Datum *) palloc(argc * sizeof(Datum));
    3854             :         }
    3855             :         else
    3856             :         {
    3857           0 :             nulls = NULL;
    3858           0 :             argvalues = NULL;
    3859             :         }
    3860             : 
    3861          10 :         for (i = 0; i < argc; i++)
    3862             :         {
    3863             :             bool        isnull;
    3864             : 
    3865          12 :             argvalues[i] = plperl_sv_to_datum(argv[i],
    3866           6 :                                               qdesc->argtypes[i],
    3867             :                                               -1,
    3868             :                                               NULL,
    3869           6 :                                               &qdesc->arginfuncs[i],
    3870           6 :                                               qdesc->argtypioparams[i],
    3871             :                                               &isnull);
    3872           6 :             nulls[i] = isnull ? 'n' : ' ';
    3873             :         }
    3874             : 
    3875             :         /************************************************************
    3876             :          * go
    3877             :          ************************************************************/
    3878           8 :         portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
    3879           4 :                                  current_call_data->prodesc->fn_readonly);
    3880           4 :         if (argc > 0)
    3881             :         {
    3882           4 :             pfree(argvalues);
    3883           4 :             pfree(nulls);
    3884             :         }
    3885           4 :         if (portal == NULL)
    3886           0 :             elog(ERROR, "SPI_cursor_open() failed:%s",
    3887             :                  SPI_result_code_string(SPI_result));
    3888             : 
    3889           4 :         cursor = cstr2sv(portal->name);
    3890             : 
    3891           4 :         PinPortal(portal);
    3892             : 
    3893             :         /* Commit the inner transaction, return to outer xact context */
    3894           4 :         ReleaseCurrentSubTransaction();
    3895           4 :         MemoryContextSwitchTo(oldcontext);
    3896           4 :         CurrentResourceOwner = oldowner;
    3897             :     }
    3898           0 :     PG_CATCH();
    3899             :     {
    3900             :         ErrorData  *edata;
    3901             : 
    3902             :         /* Save error info */
    3903           0 :         MemoryContextSwitchTo(oldcontext);
    3904           0 :         edata = CopyErrorData();
    3905           0 :         FlushErrorState();
    3906             : 
    3907             :         /* Abort the inner transaction */
    3908           0 :         RollbackAndReleaseCurrentSubTransaction();
    3909           0 :         MemoryContextSwitchTo(oldcontext);
    3910           0 :         CurrentResourceOwner = oldowner;
    3911             : 
    3912             :         /* Punt the error to Perl */
    3913           0 :         croak_cstr(edata->message);
    3914             : 
    3915             :         /* Can't get here, but keep compiler quiet */
    3916           0 :         return NULL;
    3917             :     }
    3918           4 :     PG_END_TRY();
    3919             : 
    3920           4 :     return cursor;
    3921             : }
    3922             : 
    3923             : void
    3924          10 : plperl_spi_freeplan(char *query)
    3925             : {
    3926             :     SPIPlanPtr  plan;
    3927             :     plperl_query_desc *qdesc;
    3928             :     plperl_query_entry *hash_entry;
    3929             : 
    3930          10 :     check_spi_usage_allowed();
    3931             : 
    3932          10 :     hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3933             :                              HASH_FIND, NULL);
    3934          10 :     if (hash_entry == NULL)
    3935           0 :         elog(ERROR, "spi_freeplan: Invalid prepared query passed");
    3936             : 
    3937          10 :     qdesc = hash_entry->query_data;
    3938          10 :     if (qdesc == NULL)
    3939           0 :         elog(ERROR, "spi_freeplan: plperl query_hash value vanished");
    3940          10 :     plan = qdesc->plan;
    3941             : 
    3942             :     /*
    3943             :      * free all memory before SPI_freeplan, so if it dies, nothing will be
    3944             :      * left over
    3945             :      */
    3946          10 :     hash_search(plperl_active_interp->query_hash, query,
    3947             :                 HASH_REMOVE, NULL);
    3948             : 
    3949          10 :     MemoryContextDelete(qdesc->plan_cxt);
    3950             : 
    3951          10 :     SPI_freeplan(plan);
    3952          10 : }
    3953             : 
    3954             : void
    3955          46 : plperl_spi_commit(void)
    3956             : {
    3957          46 :     MemoryContext oldcontext = CurrentMemoryContext;
    3958             : 
    3959          46 :     PG_TRY();
    3960             :     {
    3961          46 :         SPI_commit();
    3962          40 :         SPI_start_transaction();
    3963             :     }
    3964           6 :     PG_CATCH();
    3965             :     {
    3966             :         ErrorData  *edata;
    3967             : 
    3968             :         /* Save error info */
    3969           6 :         MemoryContextSwitchTo(oldcontext);
    3970           6 :         edata = CopyErrorData();
    3971           6 :         FlushErrorState();
    3972             : 
    3973             :         /* Punt the error to Perl */
    3974           6 :         croak_cstr(edata->message);
    3975             :     }
    3976          40 :     PG_END_TRY();
    3977          40 : }
    3978             : 
    3979             : void
    3980          34 : plperl_spi_rollback(void)
    3981             : {
    3982          34 :     MemoryContext oldcontext = CurrentMemoryContext;
    3983             : 
    3984          34 :     PG_TRY();
    3985             :     {
    3986          34 :         SPI_rollback();
    3987          34 :         SPI_start_transaction();
    3988             :     }
    3989           0 :     PG_CATCH();
    3990             :     {
    3991             :         ErrorData  *edata;
    3992             : 
    3993             :         /* Save error info */
    3994           0 :         MemoryContextSwitchTo(oldcontext);
    3995           0 :         edata = CopyErrorData();
    3996           0 :         FlushErrorState();
    3997             : 
    3998             :         /* Punt the error to Perl */
    3999           0 :         croak_cstr(edata->message);
    4000             :     }
    4001          34 :     PG_END_TRY();
    4002          34 : }
    4003             : 
    4004             : /*
    4005             :  * Implementation of plperl's elog() function
    4006             :  *
    4007             :  * If the error level is less than ERROR, we'll just emit the message and
    4008             :  * return.  When it is ERROR, elog() will longjmp, which we catch and
    4009             :  * turn into a Perl croak().  Note we are assuming that elog() can't have
    4010             :  * any internal failures that are so bad as to require a transaction abort.
    4011             :  *
    4012             :  * The main reason this is out-of-line is to avoid conflicts between XSUB.h
    4013             :  * and the PG_TRY macros.
    4014             :  */
    4015             : void
    4016         364 : plperl_util_elog(int level, SV *msg)
    4017             : {
    4018         364 :     MemoryContext oldcontext = CurrentMemoryContext;
    4019         364 :     char       *volatile cmsg = NULL;
    4020             : 
    4021         364 :     PG_TRY();
    4022             :     {
    4023         364 :         cmsg = sv2cstr(msg);
    4024         364 :         elog(level, "%s", cmsg);
    4025         362 :         pfree(cmsg);
    4026             :     }
    4027           2 :     PG_CATCH();
    4028             :     {
    4029             :         ErrorData  *edata;
    4030             : 
    4031             :         /* Must reset elog.c's state */
    4032           2 :         MemoryContextSwitchTo(oldcontext);
    4033           2 :         edata = CopyErrorData();
    4034           2 :         FlushErrorState();
    4035             : 
    4036           2 :         if (cmsg)
    4037           2 :             pfree(cmsg);
    4038             : 
    4039             :         /* Punt the error to Perl */
    4040           2 :         croak_cstr(edata->message);
    4041             :     }
    4042         362 :     PG_END_TRY();
    4043         362 : }
    4044             : 
    4045             : /*
    4046             :  * Store an SV into a hash table under a key that is a string assumed to be
    4047             :  * in the current database's encoding.
    4048             :  */
    4049             : static SV **
    4050        1326 : hv_store_string(HV *hv, const char *key, SV *val)
    4051             : {
    4052        1326 :     dTHX;
    4053             :     int32       hlen;
    4054             :     char       *hkey;
    4055             :     SV        **ret;
    4056             : 
    4057        1326 :     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
    4058             : 
    4059             :     /*
    4060             :      * hv_store() recognizes a negative klen parameter as meaning a UTF-8
    4061             :      * encoded key.
    4062             :      */
    4063        1326 :     hlen = -(int) strlen(hkey);
    4064        1326 :     ret = hv_store(hv, hkey, hlen, val, 0);
    4065             : 
    4066        1326 :     if (hkey != key)
    4067           0 :         pfree(hkey);
    4068             : 
    4069        1326 :     return ret;
    4070             : }
    4071             : 
    4072             : /*
    4073             :  * Fetch an SV from a hash table under a key that is a string assumed to be
    4074             :  * in the current database's encoding.
    4075             :  */
    4076             : static SV **
    4077          18 : hv_fetch_string(HV *hv, const char *key)
    4078             : {
    4079          18 :     dTHX;
    4080             :     int32       hlen;
    4081             :     char       *hkey;
    4082             :     SV        **ret;
    4083             : 
    4084          18 :     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
    4085             : 
    4086             :     /* See notes in hv_store_string */
    4087          18 :     hlen = -(int) strlen(hkey);
    4088          18 :     ret = hv_fetch(hv, hkey, hlen, 0);
    4089             : 
    4090          18 :     if (hkey != key)
    4091           0 :         pfree(hkey);
    4092             : 
    4093          18 :     return ret;
    4094             : }
    4095             : 
    4096             : /*
    4097             :  * Provide function name for PL/Perl execution errors
    4098             :  */
    4099             : static void
    4100         460 : plperl_exec_callback(void *arg)
    4101             : {
    4102         460 :     char       *procname = (char *) arg;
    4103             : 
    4104         460 :     if (procname)
    4105         460 :         errcontext("PL/Perl function \"%s\"", procname);
    4106         460 : }
    4107             : 
    4108             : /*
    4109             :  * Provide function name for PL/Perl compilation errors
    4110             :  */
    4111             : static void
    4112           8 : plperl_compile_callback(void *arg)
    4113             : {
    4114           8 :     char       *procname = (char *) arg;
    4115             : 
    4116           8 :     if (procname)
    4117           8 :         errcontext("compilation of PL/Perl function \"%s\"", procname);
    4118           8 : }
    4119             : 
    4120             : /*
    4121             :  * Provide error context for the inline handler
    4122             :  */
    4123             : static void
    4124          32 : plperl_inline_callback(void *arg)
    4125             : {
    4126          32 :     errcontext("PL/Perl anonymous code block");
    4127          32 : }
    4128             : 
    4129             : 
    4130             : /*
    4131             :  * Perl's own setlocale(), copied from POSIX.xs
    4132             :  * (needed because of the calls to new_*())
    4133             :  */
    4134             : #ifdef WIN32
    4135             : static char *
    4136             : setlocale_perl(int category, char *locale)
    4137             : {
    4138             :     dTHX;
    4139             :     char       *RETVAL = setlocale(category, locale);
    4140             : 
    4141             :     if (RETVAL)
    4142             :     {
    4143             : #ifdef USE_LOCALE_CTYPE
    4144             :         if (category == LC_CTYPE
    4145             : #ifdef LC_ALL
    4146             :             || category == LC_ALL
    4147             : #endif
    4148             :             )
    4149             :         {
    4150             :             char       *newctype;
    4151             : 
    4152             : #ifdef LC_ALL
    4153             :             if (category == LC_ALL)
    4154             :                 newctype = setlocale(LC_CTYPE, NULL);
    4155             :             else
    4156             : #endif
    4157             :                 newctype = RETVAL;
    4158             :             new_ctype(newctype);
    4159             :         }
    4160             : #endif                          /* USE_LOCALE_CTYPE */
    4161             : #ifdef USE_LOCALE_COLLATE
    4162             :         if (category == LC_COLLATE
    4163             : #ifdef LC_ALL
    4164             :             || category == LC_ALL
    4165             : #endif
    4166             :             )
    4167             :         {
    4168             :             char       *newcoll;
    4169             : 
    4170             : #ifdef LC_ALL
    4171             :             if (category == LC_ALL)
    4172             :                 newcoll = setlocale(LC_COLLATE, NULL);
    4173             :             else
    4174             : #endif
    4175             :                 newcoll = RETVAL;
    4176             :             new_collate(newcoll);
    4177             :         }
    4178             : #endif                          /* USE_LOCALE_COLLATE */
    4179             : 
    4180             : #ifdef USE_LOCALE_NUMERIC
    4181             :         if (category == LC_NUMERIC
    4182             : #ifdef LC_ALL
    4183             :             || category == LC_ALL
    4184             : #endif
    4185             :             )
    4186             :         {
    4187             :             char       *newnum;
    4188             : 
    4189             : #ifdef LC_ALL
    4190             :             if (category == LC_ALL)
    4191             :                 newnum = setlocale(LC_NUMERIC, NULL);
    4192             :             else
    4193             : #endif
    4194             :                 newnum = RETVAL;
    4195             :             new_numeric(newnum);
    4196             :         }
    4197             : #endif                          /* USE_LOCALE_NUMERIC */
    4198             :     }
    4199             : 
    4200             :     return RETVAL;
    4201             : }
    4202             : 
    4203             : #endif                          /* WIN32 */

Generated by: LCOV version 1.14