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

Generated by: LCOV version 1.13