LCOV - code coverage report
Current view: top level - src/pl/plperl - plperl.c (source / functions) Hit Total Coverage
Test: PostgreSQL 15beta1 Lines: 1268 1432 88.5 %
Date: 2022-05-19 16:10:12 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 void check_spi_usage_allowed(void);
     268             : static SV  *plperl_ref_from_pg_array(Datum arg, Oid typid);
     269             : static SV  *split_array(plperl_array_info *info, int first, int last, int nest);
     270             : static SV  *make_array_ref(plperl_array_info *info, int first, int last);
     271             : static SV  *get_perl_array_ref(SV *sv);
     272             : static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
     273             :                                 FunctionCallInfo fcinfo,
     274             :                                 FmgrInfo *finfo, Oid typioparam,
     275             :                                 bool *isnull);
     276             : static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam);
     277             : static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod);
     278             : static void array_to_datum_internal(AV *av, ArrayBuildState *astate,
     279             :                                     int *ndims, int *dims, int cur_depth,
     280             :                                     Oid arraytypid, Oid elemtypid, int32 typmod,
     281             :                                     FmgrInfo *finfo, Oid typioparam);
     282             : static Datum plperl_hash_to_datum(SV *src, TupleDesc td);
     283             : 
     284             : static void plperl_init_shared_libs(pTHX);
     285             : static void plperl_trusted_init(void);
     286             : static void plperl_untrusted_init(void);
     287             : static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int);
     288             : static void plperl_return_next_internal(SV *sv);
     289             : static char *hek2cstr(HE *he);
     290             : static SV **hv_store_string(HV *hv, const char *key, SV *val);
     291             : static SV **hv_fetch_string(HV *hv, const char *key);
     292             : static void plperl_create_sub(plperl_proc_desc *desc, const char *s, Oid fn_oid);
     293             : static SV  *plperl_call_perl_func(plperl_proc_desc *desc,
     294             :                                   FunctionCallInfo fcinfo);
     295             : static void plperl_compile_callback(void *arg);
     296             : static void plperl_exec_callback(void *arg);
     297             : static void plperl_inline_callback(void *arg);
     298             : static char *strip_trailing_ws(const char *msg);
     299             : static OP  *pp_require_safe(pTHX);
     300             : static void activate_interpreter(plperl_interp_desc *interp_desc);
     301             : 
     302             : #if defined(WIN32) && PERL_VERSION_LT(5, 28, 0)
     303             : static char *setlocale_perl(int category, char *locale);
     304             : #else
     305             : #define setlocale_perl(a,b)  Perl_setlocale(a,b)
     306             : #endif                          /* defined(WIN32) && PERL_VERSION_LT(5, 28, 0) */
     307             : 
     308             : /*
     309             :  * Decrement the refcount of the given SV within the active Perl interpreter
     310             :  *
     311             :  * This is handy because it reloads the active-interpreter pointer, saving
     312             :  * some notation in callers that switch the active interpreter.
     313             :  */
     314             : static inline void
     315         610 : SvREFCNT_dec_current(SV *sv)
     316             : {
     317         610 :     dTHX;
     318             : 
     319         610 :     SvREFCNT_dec(sv);
     320         610 : }
     321             : 
     322             : /*
     323             :  * convert a HE (hash entry) key to a cstr in the current database encoding
     324             :  */
     325             : static char *
     326         404 : hek2cstr(HE *he)
     327             : {
     328         404 :     dTHX;
     329             :     char       *ret;
     330             :     SV         *sv;
     331             : 
     332             :     /*
     333             :      * HeSVKEY_force will return a temporary mortal SV*, so we need to make
     334             :      * sure to free it with ENTER/SAVE/FREE/LEAVE
     335             :      */
     336         404 :     ENTER;
     337         404 :     SAVETMPS;
     338             : 
     339             :     /*-------------------------
     340             :      * Unfortunately, while HeUTF8 is true for most things > 256, for values
     341             :      * 128..255 it's not, but perl will treat them as unicode code points if
     342             :      * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
     343             :      * for more)
     344             :      *
     345             :      * So if we did the expected:
     346             :      *    if (HeUTF8(he))
     347             :      *        utf_u2e(key...);
     348             :      *    else // must be ascii
     349             :      *        return HePV(he);
     350             :      * we won't match columns with codepoints from 128..255
     351             :      *
     352             :      * For a more concrete example given a column with the name of the unicode
     353             :      * codepoint U+00ae (registered sign) and a UTF8 database and the perl
     354             :      * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
     355             :      * 0 and HePV() would give us a char * with 1 byte contains the decimal
     356             :      * value 174
     357             :      *
     358             :      * Perl has the brains to know when it should utf8 encode 174 properly, so
     359             :      * here we force it into an SV so that perl will figure it out and do the
     360             :      * right thing
     361             :      *-------------------------
     362             :      */
     363             : 
     364         404 :     sv = HeSVKEY_force(he);
     365         404 :     if (HeUTF8(he))
     366           0 :         SvUTF8_on(sv);
     367         404 :     ret = sv2cstr(sv);
     368             : 
     369             :     /* free sv */
     370         404 :     FREETMPS;
     371         404 :     LEAVE;
     372             : 
     373         404 :     return ret;
     374             : }
     375             : 
     376             : 
     377             : /*
     378             :  * _PG_init()           - library load-time initialization
     379             :  *
     380             :  * DO NOT make this static nor change its name!
     381             :  */
     382             : void
     383          42 : _PG_init(void)
     384             : {
     385             :     /*
     386             :      * Be sure we do initialization only once.
     387             :      *
     388             :      * If initialization fails due to, e.g., plperl_init_interp() throwing an
     389             :      * exception, then we'll return here on the next usage and the user will
     390             :      * get a rather cryptic: ERROR:  attempt to redefine parameter
     391             :      * "plperl.use_strict"
     392             :      */
     393             :     static bool inited = false;
     394             :     HASHCTL     hash_ctl;
     395             : 
     396          42 :     if (inited)
     397           0 :         return;
     398             : 
     399             :     /*
     400             :      * Support localized messages.
     401             :      */
     402          42 :     pg_bindtextdomain(TEXTDOMAIN);
     403             : 
     404             :     /*
     405             :      * Initialize plperl's GUCs.
     406             :      */
     407          42 :     DefineCustomBoolVariable("plperl.use_strict",
     408             :                              gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
     409             :                              NULL,
     410             :                              &plperl_use_strict,
     411             :                              false,
     412             :                              PGC_USERSET, 0,
     413             :                              NULL, NULL, NULL);
     414             : 
     415             :     /*
     416             :      * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
     417             :      * be executed in the postmaster (if plperl is loaded into the postmaster
     418             :      * via shared_preload_libraries).  This isn't really right either way,
     419             :      * though.
     420             :      */
     421          42 :     DefineCustomStringVariable("plperl.on_init",
     422             :                                gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
     423             :                                NULL,
     424             :                                &plperl_on_init,
     425             :                                NULL,
     426             :                                PGC_SIGHUP, 0,
     427             :                                NULL, NULL, NULL);
     428             : 
     429             :     /*
     430             :      * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
     431             :      * user who might not even have USAGE privilege on the plperl language
     432             :      * could nonetheless use SET plperl.on_plperl_init='...' to influence the
     433             :      * behaviour of any existing plperl function that they can execute (which
     434             :      * might be SECURITY DEFINER, leading to a privilege escalation).  See
     435             :      * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
     436             :      * the overall thread.
     437             :      *
     438             :      * Note that because plperl.use_strict is USERSET, a nefarious user could
     439             :      * set it to be applied against other people's functions.  This is judged
     440             :      * OK since the worst result would be an error.  Your code oughta pass
     441             :      * use_strict anyway ;-)
     442             :      */
     443          42 :     DefineCustomStringVariable("plperl.on_plperl_init",
     444             :                                gettext_noop("Perl initialization code to execute once when plperl is first used."),
     445             :                                NULL,
     446             :                                &plperl_on_plperl_init,
     447             :                                NULL,
     448             :                                PGC_SUSET, 0,
     449             :                                NULL, NULL, NULL);
     450             : 
     451          42 :     DefineCustomStringVariable("plperl.on_plperlu_init",
     452             :                                gettext_noop("Perl initialization code to execute once when plperlu is first used."),
     453             :                                NULL,
     454             :                                &plperl_on_plperlu_init,
     455             :                                NULL,
     456             :                                PGC_SUSET, 0,
     457             :                                NULL, NULL, NULL);
     458             : 
     459          42 :     MarkGUCPrefixReserved("plperl");
     460             : 
     461             :     /*
     462             :      * Create hash tables.
     463             :      */
     464          42 :     hash_ctl.keysize = sizeof(Oid);
     465          42 :     hash_ctl.entrysize = sizeof(plperl_interp_desc);
     466          42 :     plperl_interp_hash = hash_create("PL/Perl interpreters",
     467             :                                      8,
     468             :                                      &hash_ctl,
     469             :                                      HASH_ELEM | HASH_BLOBS);
     470             : 
     471          42 :     hash_ctl.keysize = sizeof(plperl_proc_key);
     472          42 :     hash_ctl.entrysize = sizeof(plperl_proc_ptr);
     473          42 :     plperl_proc_hash = hash_create("PL/Perl procedures",
     474             :                                    32,
     475             :                                    &hash_ctl,
     476             :                                    HASH_ELEM | HASH_BLOBS);
     477             : 
     478             :     /*
     479             :      * Save the default opmask.
     480             :      */
     481          42 :     PLPERL_SET_OPMASK(plperl_opmask);
     482             : 
     483             :     /*
     484             :      * Create the first Perl interpreter, but only partially initialize it.
     485             :      */
     486          42 :     plperl_held_interp = plperl_init_interp();
     487             : 
     488          42 :     inited = true;
     489             : }
     490             : 
     491             : 
     492             : static void
     493          92 : set_interp_require(bool trusted)
     494             : {
     495          92 :     if (trusted)
     496             :     {
     497          56 :         PL_ppaddr[OP_REQUIRE] = pp_require_safe;
     498          56 :         PL_ppaddr[OP_DOFILE] = pp_require_safe;
     499             :     }
     500             :     else
     501             :     {
     502          36 :         PL_ppaddr[OP_REQUIRE] = pp_require_orig;
     503          36 :         PL_ppaddr[OP_DOFILE] = pp_require_orig;
     504             :     }
     505          92 : }
     506             : 
     507             : /*
     508             :  * Cleanup perl interpreters, including running END blocks.
     509             :  * Does not fully undo the actions of _PG_init() nor make it callable again.
     510             :  */
     511             : static void
     512          38 : plperl_fini(int code, Datum arg)
     513             : {
     514             :     HASH_SEQ_STATUS hash_seq;
     515             :     plperl_interp_desc *interp_desc;
     516             : 
     517          38 :     elog(DEBUG3, "plperl_fini");
     518             : 
     519             :     /*
     520             :      * Indicate that perl is terminating. Disables use of spi_* functions when
     521             :      * running END/DESTROY code. See check_spi_usage_allowed(). Could be
     522             :      * enabled in future, with care, using a transaction
     523             :      * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
     524             :      */
     525          38 :     plperl_ending = true;
     526             : 
     527             :     /* Only perform perl cleanup if we're exiting cleanly */
     528          38 :     if (code)
     529             :     {
     530           0 :         elog(DEBUG3, "plperl_fini: skipped");
     531           0 :         return;
     532             :     }
     533             : 
     534             :     /* Zap the "held" interpreter, if we still have it */
     535          38 :     plperl_destroy_interp(&plperl_held_interp);
     536             : 
     537             :     /* Zap any fully-initialized interpreters */
     538          38 :     hash_seq_init(&hash_seq, plperl_interp_hash);
     539          78 :     while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
     540             :     {
     541          40 :         if (interp_desc->interp)
     542             :         {
     543          40 :             activate_interpreter(interp_desc);
     544          40 :             plperl_destroy_interp(&interp_desc->interp);
     545             :         }
     546             :     }
     547             : 
     548          38 :     elog(DEBUG3, "plperl_fini: done");
     549             : }
     550             : 
     551             : 
     552             : /*
     553             :  * Select and activate an appropriate Perl interpreter.
     554             :  */
     555             : static void
     556         332 : select_perl_context(bool trusted)
     557             : {
     558             :     Oid         user_id;
     559             :     plperl_interp_desc *interp_desc;
     560             :     bool        found;
     561         332 :     PerlInterpreter *interp = NULL;
     562             : 
     563             :     /* Find or create the interpreter hashtable entry for this userid */
     564         332 :     if (trusted)
     565         282 :         user_id = GetUserId();
     566             :     else
     567          50 :         user_id = InvalidOid;
     568             : 
     569         332 :     interp_desc = hash_search(plperl_interp_hash, &user_id,
     570             :                               HASH_ENTER,
     571             :                               &found);
     572         332 :     if (!found)
     573             :     {
     574             :         /* Initialize newly-created hashtable entry */
     575          42 :         interp_desc->interp = NULL;
     576          42 :         interp_desc->query_hash = NULL;
     577             :     }
     578             : 
     579             :     /* Make sure we have a query_hash for this interpreter */
     580         332 :     if (interp_desc->query_hash == NULL)
     581             :     {
     582             :         HASHCTL     hash_ctl;
     583             : 
     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 | HASH_STRINGS);
     590             :     }
     591             : 
     592             :     /*
     593             :      * Quick exit if already have an interpreter
     594             :      */
     595         332 :     if (interp_desc->interp)
     596             :     {
     597         290 :         activate_interpreter(interp_desc);
     598         290 :         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        1826 : activate_interpreter(plperl_interp_desc *interp_desc)
     688             : {
     689        1826 :     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        1826 : }
     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          54 : strip_trailing_ws(const char *msg)
    1065             : {
    1066          54 :     char       *res = pstrdup(msg);
    1067          54 :     int         len = strlen(res);
    1068             : 
    1069         108 :     while (len > 0 && isspace((unsigned char) res[len - 1]))
    1070          54 :         res[--len] = '\0';
    1071          54 :     return res;
    1072             : }
    1073             : 
    1074             : 
    1075             : /* Build a tuple from a hash. */
    1076             : 
    1077             : static HeapTuple
    1078         160 : plperl_build_tuple_result(HV *perlhash, TupleDesc td)
    1079             : {
    1080         160 :     dTHX;
    1081             :     Datum      *values;
    1082             :     bool       *nulls;
    1083             :     HE         *he;
    1084             :     HeapTuple   tup;
    1085             : 
    1086         160 :     values = palloc0(sizeof(Datum) * td->natts);
    1087         160 :     nulls = palloc(sizeof(bool) * td->natts);
    1088         160 :     memset(nulls, true, sizeof(bool) * td->natts);
    1089             : 
    1090         160 :     hv_iterinit(perlhash);
    1091         530 :     while ((he = hv_iternext(perlhash)))
    1092             :     {
    1093         374 :         SV         *val = HeVAL(he);
    1094         374 :         char       *key = hek2cstr(he);
    1095         374 :         int         attn = SPI_fnumber(td, key);
    1096         374 :         Form_pg_attribute attr = TupleDescAttr(td, attn - 1);
    1097             : 
    1098         374 :         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         370 :         if (attn <= 0)
    1104           0 :             ereport(ERROR,
    1105             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1106             :                      errmsg("cannot set system attribute \"%s\"",
    1107             :                             key)));
    1108             : 
    1109         740 :         values[attn - 1] = plperl_sv_to_datum(val,
    1110             :                                               attr->atttypid,
    1111             :                                               attr->atttypmod,
    1112             :                                               NULL,
    1113             :                                               NULL,
    1114             :                                               InvalidOid,
    1115         370 :                                               &nulls[attn - 1]);
    1116             : 
    1117         370 :         pfree(key);
    1118             :     }
    1119         156 :     hv_iterinit(perlhash);
    1120             : 
    1121         156 :     tup = heap_form_tuple(td, values, nulls);
    1122         156 :     pfree(values);
    1123         156 :     pfree(nulls);
    1124         156 :     return tup;
    1125             : }
    1126             : 
    1127             : /* convert a hash reference to a datum */
    1128             : static Datum
    1129          82 : plperl_hash_to_datum(SV *src, TupleDesc td)
    1130             : {
    1131          82 :     HeapTuple   tup = plperl_build_tuple_result((HV *) SvRV(src), td);
    1132             : 
    1133          80 :     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         700 : get_perl_array_ref(SV *sv)
    1142             : {
    1143         700 :     dTHX;
    1144             : 
    1145         700 :     if (SvOK(sv) && SvROK(sv))
    1146             :     {
    1147         374 :         if (SvTYPE(SvRV(sv)) == SVt_PVAV)
    1148         268 :             return sv;
    1149         106 :         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         430 :     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         396 : _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         396 :     getTypeInputInfo(typid,
    1293             :                      &typinput, typioparam);
    1294         396 :     fmgr_info(typinput, finfo);
    1295         396 : }
    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        1272 : 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        1272 :     check_stack_depth();
    1320             : 
    1321        1272 :     *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        1272 :     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        1194 :     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        1038 :     else if (SvROK(sv))
    1343             :     {
    1344             :         /* handle references */
    1345         152 :         SV         *sav = get_perl_array_ref(sv);
    1346             : 
    1347         152 :         if (sav)
    1348             :         {
    1349             :             /* handle an arrayref */
    1350          62 :             return plperl_array_to_datum(sav, typid, typmod);
    1351             :         }
    1352          90 :         else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
    1353             :         {
    1354             :             /* handle a hashref */
    1355             :             Datum       ret;
    1356             :             TupleDesc   td;
    1357             :             bool        isdomain;
    1358             : 
    1359          88 :             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          84 :             td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
    1366          84 :             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          16 :                 if (fcinfo)
    1377          16 :                     funcclass = get_call_result_type(fcinfo, &typid, &td);
    1378             :                 else
    1379           0 :                     funcclass = TYPEFUNC_OTHER;
    1380          16 :                 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          14 :                 isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
    1388             :             }
    1389             : 
    1390          82 :             ret = plperl_hash_to_datum(sv, td);
    1391             : 
    1392          80 :             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          76 :             ReleaseTupleDesc(td);
    1397             : 
    1398          76 :             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         886 :         char       *str = sv2cstr(sv);
    1414             : 
    1415             :         /* did not pass in any typeinfo? look it up */
    1416         884 :         if (!finfo)
    1417             :         {
    1418         328 :             _sv_to_datum_finfo(typid, &tmp, &typioparam);
    1419         328 :             finfo = &tmp;
    1420             :         }
    1421             : 
    1422         884 :         ret = InputFunctionCall(finfo, str, typioparam, typmod);
    1423         882 :         pfree(str);
    1424             : 
    1425         882 :         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             :     Oid         typid;
    1434             :     Oid         typoutput;
    1435             :     Datum       datum;
    1436             :     bool        typisvarlena,
    1437             :                 isnull;
    1438             : 
    1439          32 :     check_spi_usage_allowed();
    1440             : 
    1441          32 :     typid = DirectFunctionCall1(regtypein, CStringGetDatum(fqtypename));
    1442          32 :     if (!OidIsValid(typid))
    1443           0 :         ereport(ERROR,
    1444             :                 (errcode(ERRCODE_UNDEFINED_OBJECT),
    1445             :                  errmsg("lookup failed for type %s", fqtypename)));
    1446             : 
    1447          32 :     datum = plperl_sv_to_datum(sv,
    1448             :                                typid, -1,
    1449             :                                NULL, NULL, InvalidOid,
    1450             :                                &isnull);
    1451             : 
    1452          30 :     if (isnull)
    1453           2 :         return NULL;
    1454             : 
    1455          28 :     getTypeOutputInfo(typid,
    1456             :                       &typoutput, &typisvarlena);
    1457             : 
    1458          28 :     return OidOutputFunctionCall(typoutput, datum);
    1459             : }
    1460             : 
    1461             : /*
    1462             :  * Convert PostgreSQL array datum to a perl array reference.
    1463             :  *
    1464             :  * typid is arg's OID, which must be an array type.
    1465             :  */
    1466             : static SV  *
    1467          34 : plperl_ref_from_pg_array(Datum arg, Oid typid)
    1468             : {
    1469          34 :     dTHX;
    1470          34 :     ArrayType  *ar = DatumGetArrayTypeP(arg);
    1471          34 :     Oid         elementtype = ARR_ELEMTYPE(ar);
    1472             :     int16       typlen;
    1473             :     bool        typbyval;
    1474             :     char        typalign,
    1475             :                 typdelim;
    1476             :     Oid         typioparam;
    1477             :     Oid         typoutputfunc;
    1478             :     Oid         transform_funcid;
    1479             :     int         i,
    1480             :                 nitems,
    1481             :                *dims;
    1482             :     plperl_array_info *info;
    1483             :     SV         *av;
    1484             :     HV         *hv;
    1485             : 
    1486             :     /*
    1487             :      * Currently we make no effort to cache any of the stuff we look up here,
    1488             :      * which is bad.
    1489             :      */
    1490          34 :     info = palloc0(sizeof(plperl_array_info));
    1491             : 
    1492             :     /* get element type information, including output conversion function */
    1493          34 :     get_type_io_data(elementtype, IOFunc_output,
    1494             :                      &typlen, &typbyval, &typalign,
    1495             :                      &typdelim, &typioparam, &typoutputfunc);
    1496             : 
    1497             :     /* Check for a transform function */
    1498          34 :     transform_funcid = get_transform_fromsql(elementtype,
    1499          34 :                                              current_call_data->prodesc->lang_oid,
    1500          34 :                                              current_call_data->prodesc->trftypes);
    1501             : 
    1502             :     /* Look up transform or output function as appropriate */
    1503          34 :     if (OidIsValid(transform_funcid))
    1504           2 :         fmgr_info(transform_funcid, &info->transform_proc);
    1505             :     else
    1506          32 :         fmgr_info(typoutputfunc, &info->proc);
    1507             : 
    1508          34 :     info->elem_is_rowtype = type_is_rowtype(elementtype);
    1509             : 
    1510             :     /* Get the number and bounds of array dimensions */
    1511          34 :     info->ndims = ARR_NDIM(ar);
    1512          34 :     dims = ARR_DIMS(ar);
    1513             : 
    1514             :     /* No dimensions? Return an empty array */
    1515          34 :     if (info->ndims == 0)
    1516             :     {
    1517           2 :         av = newRV_noinc((SV *) newAV());
    1518             :     }
    1519             :     else
    1520             :     {
    1521          32 :         deconstruct_array(ar, elementtype, typlen, typbyval,
    1522             :                           typalign, &info->elements, &info->nulls,
    1523             :                           &nitems);
    1524             : 
    1525             :         /* Get total number of elements in each dimension */
    1526          32 :         info->nelems = palloc(sizeof(int) * info->ndims);
    1527          32 :         info->nelems[0] = nitems;
    1528          56 :         for (i = 1; i < info->ndims; i++)
    1529          24 :             info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
    1530             : 
    1531          32 :         av = split_array(info, 0, nitems, 0);
    1532             :     }
    1533             : 
    1534          34 :     hv = newHV();
    1535          34 :     (void) hv_store(hv, "array", 5, av, 0);
    1536          34 :     (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0);
    1537             : 
    1538          34 :     return sv_bless(newRV_noinc((SV *) hv),
    1539             :                     gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
    1540             : }
    1541             : 
    1542             : /*
    1543             :  * Recursively form array references from splices of the initial array
    1544             :  */
    1545             : static SV  *
    1546         192 : split_array(plperl_array_info *info, int first, int last, int nest)
    1547             : {
    1548         192 :     dTHX;
    1549             :     int         i;
    1550             :     AV         *result;
    1551             : 
    1552             :     /* we should only be called when we have something to split */
    1553             :     Assert(info->ndims > 0);
    1554             : 
    1555             :     /* since this function recurses, it could be driven to stack overflow */
    1556         192 :     check_stack_depth();
    1557             : 
    1558             :     /*
    1559             :      * Base case, return a reference to a single-dimensional array
    1560             :      */
    1561         192 :     if (nest >= info->ndims - 1)
    1562         114 :         return make_array_ref(info, first, last);
    1563             : 
    1564          78 :     result = newAV();
    1565         238 :     for (i = first; i < last; i += info->nelems[nest + 1])
    1566             :     {
    1567             :         /* Recursively form references to arrays of lower dimensions */
    1568         160 :         SV         *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1);
    1569             : 
    1570         160 :         av_push(result, ref);
    1571             :     }
    1572          78 :     return newRV_noinc((SV *) result);
    1573             : }
    1574             : 
    1575             : /*
    1576             :  * Create a Perl reference from a one-dimensional C array, converting
    1577             :  * composite type elements to hash references.
    1578             :  */
    1579             : static SV  *
    1580         114 : make_array_ref(plperl_array_info *info, int first, int last)
    1581             : {
    1582         114 :     dTHX;
    1583             :     int         i;
    1584         114 :     AV         *result = newAV();
    1585             : 
    1586         386 :     for (i = first; i < last; i++)
    1587             :     {
    1588         272 :         if (info->nulls[i])
    1589             :         {
    1590             :             /*
    1591             :              * We can't use &PL_sv_undef here.  See "AVs, HVs and undefined
    1592             :              * values" in perlguts.
    1593             :              */
    1594           8 :             av_push(result, newSV(0));
    1595             :         }
    1596             :         else
    1597             :         {
    1598         264 :             Datum       itemvalue = info->elements[i];
    1599             : 
    1600         264 :             if (info->transform_proc.fn_oid)
    1601           4 :                 av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue)));
    1602         260 :             else if (info->elem_is_rowtype)
    1603             :                 /* Handle composite type elements */
    1604           8 :                 av_push(result, plperl_hash_from_datum(itemvalue));
    1605             :             else
    1606             :             {
    1607         252 :                 char       *val = OutputFunctionCall(&info->proc, itemvalue);
    1608             : 
    1609         252 :                 av_push(result, cstr2sv(val));
    1610             :             }
    1611             :         }
    1612             :     }
    1613         114 :     return newRV_noinc((SV *) result);
    1614             : }
    1615             : 
    1616             : /* Set up the arguments for a trigger call. */
    1617             : static SV  *
    1618          60 : plperl_trigger_build_args(FunctionCallInfo fcinfo)
    1619             : {
    1620          60 :     dTHX;
    1621             :     TriggerData *tdata;
    1622             :     TupleDesc   tupdesc;
    1623             :     int         i;
    1624             :     char       *level;
    1625             :     char       *event;
    1626             :     char       *relid;
    1627             :     char       *when;
    1628             :     HV         *hv;
    1629             : 
    1630          60 :     hv = newHV();
    1631          60 :     hv_ksplit(hv, 12);          /* pre-grow the hash */
    1632             : 
    1633          60 :     tdata = (TriggerData *) fcinfo->context;
    1634          60 :     tupdesc = tdata->tg_relation->rd_att;
    1635             : 
    1636          60 :     relid = DatumGetCString(DirectFunctionCall1(oidout,
    1637             :                                                 ObjectIdGetDatum(tdata->tg_relation->rd_id)));
    1638             : 
    1639          60 :     hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
    1640          60 :     hv_store_string(hv, "relid", cstr2sv(relid));
    1641             : 
    1642             :     /*
    1643             :      * Note: In BEFORE trigger, stored generated columns are not computed yet,
    1644             :      * so don't make them accessible in NEW row.
    1645             :      */
    1646             : 
    1647          60 :     if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
    1648             :     {
    1649          24 :         event = "INSERT";
    1650          24 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1651          24 :             hv_store_string(hv, "new",
    1652             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1653             :                                                    tupdesc,
    1654          24 :                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
    1655             :     }
    1656          36 :     else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
    1657             :     {
    1658          20 :         event = "DELETE";
    1659          20 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1660          20 :             hv_store_string(hv, "old",
    1661             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1662             :                                                    tupdesc,
    1663             :                                                    true));
    1664             :     }
    1665          16 :     else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
    1666             :     {
    1667          16 :         event = "UPDATE";
    1668          16 :         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1669             :         {
    1670          14 :             hv_store_string(hv, "old",
    1671             :                             plperl_hash_from_tuple(tdata->tg_trigtuple,
    1672             :                                                    tupdesc,
    1673             :                                                    true));
    1674          14 :             hv_store_string(hv, "new",
    1675             :                             plperl_hash_from_tuple(tdata->tg_newtuple,
    1676             :                                                    tupdesc,
    1677          14 :                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
    1678             :         }
    1679             :     }
    1680           0 :     else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
    1681           0 :         event = "TRUNCATE";
    1682             :     else
    1683           0 :         event = "UNKNOWN";
    1684             : 
    1685          60 :     hv_store_string(hv, "event", cstr2sv(event));
    1686          60 :     hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
    1687             : 
    1688          60 :     if (tdata->tg_trigger->tgnargs > 0)
    1689             :     {
    1690          24 :         AV         *av = newAV();
    1691             : 
    1692          24 :         av_extend(av, tdata->tg_trigger->tgnargs);
    1693          60 :         for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
    1694          36 :             av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
    1695          24 :         hv_store_string(hv, "args", newRV_noinc((SV *) av));
    1696             :     }
    1697             : 
    1698          60 :     hv_store_string(hv, "relname",
    1699          60 :                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
    1700             : 
    1701          60 :     hv_store_string(hv, "table_name",
    1702          60 :                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
    1703             : 
    1704          60 :     hv_store_string(hv, "table_schema",
    1705          60 :                     cstr2sv(SPI_getnspname(tdata->tg_relation)));
    1706             : 
    1707          60 :     if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
    1708          46 :         when = "BEFORE";
    1709          14 :     else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
    1710           8 :         when = "AFTER";
    1711           6 :     else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
    1712           6 :         when = "INSTEAD OF";
    1713             :     else
    1714           0 :         when = "UNKNOWN";
    1715          60 :     hv_store_string(hv, "when", cstr2sv(when));
    1716             : 
    1717          60 :     if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
    1718          58 :         level = "ROW";
    1719           2 :     else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
    1720           2 :         level = "STATEMENT";
    1721             :     else
    1722           0 :         level = "UNKNOWN";
    1723          60 :     hv_store_string(hv, "level", cstr2sv(level));
    1724             : 
    1725          60 :     return newRV_noinc((SV *) hv);
    1726             : }
    1727             : 
    1728             : 
    1729             : /* Set up the arguments for an event trigger call. */
    1730             : static SV  *
    1731          20 : plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
    1732             : {
    1733          20 :     dTHX;
    1734             :     EventTriggerData *tdata;
    1735             :     HV         *hv;
    1736             : 
    1737          20 :     hv = newHV();
    1738             : 
    1739          20 :     tdata = (EventTriggerData *) fcinfo->context;
    1740             : 
    1741          20 :     hv_store_string(hv, "event", cstr2sv(tdata->event));
    1742          20 :     hv_store_string(hv, "tag", cstr2sv(GetCommandTagName(tdata->tag)));
    1743             : 
    1744          20 :     return newRV_noinc((SV *) hv);
    1745             : }
    1746             : 
    1747             : /* Construct the modified new tuple to be returned from a trigger. */
    1748             : static HeapTuple
    1749          12 : plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
    1750             : {
    1751          12 :     dTHX;
    1752             :     SV        **svp;
    1753             :     HV         *hvNew;
    1754             :     HE         *he;
    1755             :     HeapTuple   rtup;
    1756             :     TupleDesc   tupdesc;
    1757             :     int         natts;
    1758             :     Datum      *modvalues;
    1759             :     bool       *modnulls;
    1760             :     bool       *modrepls;
    1761             : 
    1762          12 :     svp = hv_fetch_string(hvTD, "new");
    1763          12 :     if (!svp)
    1764           0 :         ereport(ERROR,
    1765             :                 (errcode(ERRCODE_UNDEFINED_COLUMN),
    1766             :                  errmsg("$_TD->{new} does not exist")));
    1767          12 :     if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
    1768           0 :         ereport(ERROR,
    1769             :                 (errcode(ERRCODE_DATATYPE_MISMATCH),
    1770             :                  errmsg("$_TD->{new} is not a hash reference")));
    1771          12 :     hvNew = (HV *) SvRV(*svp);
    1772             : 
    1773          12 :     tupdesc = tdata->tg_relation->rd_att;
    1774          12 :     natts = tupdesc->natts;
    1775             : 
    1776          12 :     modvalues = (Datum *) palloc0(natts * sizeof(Datum));
    1777          12 :     modnulls = (bool *) palloc0(natts * sizeof(bool));
    1778          12 :     modrepls = (bool *) palloc0(natts * sizeof(bool));
    1779             : 
    1780          12 :     hv_iterinit(hvNew);
    1781          40 :     while ((he = hv_iternext(hvNew)))
    1782             :     {
    1783          30 :         char       *key = hek2cstr(he);
    1784          30 :         SV         *val = HeVAL(he);
    1785          30 :         int         attn = SPI_fnumber(tupdesc, key);
    1786          30 :         Form_pg_attribute attr = TupleDescAttr(tupdesc, attn - 1);
    1787             : 
    1788          30 :         if (attn == SPI_ERROR_NOATTRIBUTE)
    1789           0 :             ereport(ERROR,
    1790             :                     (errcode(ERRCODE_UNDEFINED_COLUMN),
    1791             :                      errmsg("Perl hash contains nonexistent column \"%s\"",
    1792             :                             key)));
    1793          30 :         if (attn <= 0)
    1794           0 :             ereport(ERROR,
    1795             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    1796             :                      errmsg("cannot set system attribute \"%s\"",
    1797             :                             key)));
    1798          30 :         if (attr->attgenerated)
    1799           2 :             ereport(ERROR,
    1800             :                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    1801             :                      errmsg("cannot set generated column \"%s\"",
    1802             :                             key)));
    1803             : 
    1804          56 :         modvalues[attn - 1] = plperl_sv_to_datum(val,
    1805             :                                                  attr->atttypid,
    1806             :                                                  attr->atttypmod,
    1807             :                                                  NULL,
    1808             :                                                  NULL,
    1809             :                                                  InvalidOid,
    1810          28 :                                                  &modnulls[attn - 1]);
    1811          28 :         modrepls[attn - 1] = true;
    1812             : 
    1813          28 :         pfree(key);
    1814             :     }
    1815          10 :     hv_iterinit(hvNew);
    1816             : 
    1817          10 :     rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls);
    1818             : 
    1819          10 :     pfree(modvalues);
    1820          10 :     pfree(modnulls);
    1821          10 :     pfree(modrepls);
    1822             : 
    1823          10 :     return rtup;
    1824             : }
    1825             : 
    1826             : 
    1827             : /*
    1828             :  * There are three externally visible pieces to plperl: plperl_call_handler,
    1829             :  * plperl_inline_handler, and plperl_validator.
    1830             :  */
    1831             : 
    1832             : /*
    1833             :  * The call handler is called to run normal functions (including trigger
    1834             :  * functions) that are defined in pg_proc.
    1835             :  */
    1836          42 : PG_FUNCTION_INFO_V1(plperl_call_handler);
    1837             : 
    1838             : Datum
    1839         536 : plperl_call_handler(PG_FUNCTION_ARGS)
    1840             : {
    1841         536 :     Datum       retval = (Datum) 0;
    1842         536 :     plperl_call_data *volatile save_call_data = current_call_data;
    1843         536 :     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
    1844             :     plperl_call_data this_call_data;
    1845             : 
    1846             :     /* Initialize current-call status record */
    1847        4288 :     MemSet(&this_call_data, 0, sizeof(this_call_data));
    1848         536 :     this_call_data.fcinfo = fcinfo;
    1849             : 
    1850         536 :     PG_TRY();
    1851             :     {
    1852         536 :         current_call_data = &this_call_data;
    1853         536 :         if (CALLED_AS_TRIGGER(fcinfo))
    1854          60 :             retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
    1855         476 :         else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
    1856             :         {
    1857          20 :             plperl_event_trigger_handler(fcinfo);
    1858          20 :             retval = (Datum) 0;
    1859             :         }
    1860             :         else
    1861         456 :             retval = plperl_func_handler(fcinfo);
    1862             :     }
    1863          76 :     PG_FINALLY();
    1864             :     {
    1865         536 :         current_call_data = save_call_data;
    1866         536 :         activate_interpreter(oldinterp);
    1867         536 :         if (this_call_data.prodesc)
    1868         534 :             decrement_prodesc_refcount(this_call_data.prodesc);
    1869             :     }
    1870         536 :     PG_END_TRY();
    1871             : 
    1872         460 :     return retval;
    1873             : }
    1874             : 
    1875             : /*
    1876             :  * The inline handler runs anonymous code blocks (DO blocks).
    1877             :  */
    1878          20 : PG_FUNCTION_INFO_V1(plperl_inline_handler);
    1879             : 
    1880             : Datum
    1881          40 : plperl_inline_handler(PG_FUNCTION_ARGS)
    1882             : {
    1883          40 :     LOCAL_FCINFO(fake_fcinfo, 0);
    1884          40 :     InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
    1885             :     FmgrInfo    flinfo;
    1886             :     plperl_proc_desc desc;
    1887          40 :     plperl_call_data *volatile save_call_data = current_call_data;
    1888          40 :     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
    1889             :     plperl_call_data this_call_data;
    1890             :     ErrorContextCallback pl_error_context;
    1891             : 
    1892             :     /* Initialize current-call status record */
    1893         320 :     MemSet(&this_call_data, 0, sizeof(this_call_data));
    1894             : 
    1895             :     /* Set up a callback for error reporting */
    1896          40 :     pl_error_context.callback = plperl_inline_callback;
    1897          40 :     pl_error_context.previous = error_context_stack;
    1898          40 :     pl_error_context.arg = NULL;
    1899          40 :     error_context_stack = &pl_error_context;
    1900             : 
    1901             :     /*
    1902             :      * Set up a fake fcinfo and descriptor with just enough info to satisfy
    1903             :      * plperl_call_perl_func().  In particular note that this sets things up
    1904             :      * with no arguments passed, and a result type of VOID.
    1905             :      */
    1906         200 :     MemSet(fake_fcinfo, 0, SizeForFunctionCallInfo(0));
    1907         280 :     MemSet(&flinfo, 0, sizeof(flinfo));
    1908         840 :     MemSet(&desc, 0, sizeof(desc));
    1909          40 :     fake_fcinfo->flinfo = &flinfo;
    1910          40 :     flinfo.fn_oid = InvalidOid;
    1911          40 :     flinfo.fn_mcxt = CurrentMemoryContext;
    1912             : 
    1913          40 :     desc.proname = "inline_code_block";
    1914          40 :     desc.fn_readonly = false;
    1915             : 
    1916          40 :     desc.lang_oid = codeblock->langOid;
    1917          40 :     desc.trftypes = NIL;
    1918          40 :     desc.lanpltrusted = codeblock->langIsTrusted;
    1919             : 
    1920          40 :     desc.fn_retistuple = false;
    1921          40 :     desc.fn_retisset = false;
    1922          40 :     desc.fn_retisarray = false;
    1923          40 :     desc.result_oid = InvalidOid;
    1924          40 :     desc.nargs = 0;
    1925          40 :     desc.reference = NULL;
    1926             : 
    1927          40 :     this_call_data.fcinfo = fake_fcinfo;
    1928          40 :     this_call_data.prodesc = &desc;
    1929             :     /* we do not bother with refcounting the fake prodesc */
    1930             : 
    1931          40 :     PG_TRY();
    1932             :     {
    1933             :         SV         *perlret;
    1934             : 
    1935          40 :         current_call_data = &this_call_data;
    1936             : 
    1937          40 :         if (SPI_connect_ext(codeblock->atomic ? 0 : SPI_OPT_NONATOMIC) != SPI_OK_CONNECT)
    1938           0 :             elog(ERROR, "could not connect to SPI manager");
    1939             : 
    1940          40 :         select_perl_context(desc.lanpltrusted);
    1941             : 
    1942          38 :         plperl_create_sub(&desc, codeblock->source_text, 0);
    1943             : 
    1944          28 :         if (!desc.reference)    /* can this happen? */
    1945           0 :             elog(ERROR, "could not create internal procedure for anonymous code block");
    1946             : 
    1947          28 :         perlret = plperl_call_perl_func(&desc, fake_fcinfo);
    1948             : 
    1949          18 :         SvREFCNT_dec_current(perlret);
    1950             : 
    1951          18 :         if (SPI_finish() != SPI_OK_FINISH)
    1952           0 :             elog(ERROR, "SPI_finish() failed");
    1953             :     }
    1954          22 :     PG_FINALLY();
    1955             :     {
    1956          40 :         if (desc.reference)
    1957          28 :             SvREFCNT_dec_current(desc.reference);
    1958          40 :         current_call_data = save_call_data;
    1959          40 :         activate_interpreter(oldinterp);
    1960             :     }
    1961          40 :     PG_END_TRY();
    1962             : 
    1963          18 :     error_context_stack = pl_error_context.previous;
    1964             : 
    1965          18 :     PG_RETURN_VOID();
    1966             : }
    1967             : 
    1968             : /*
    1969             :  * The validator is called during CREATE FUNCTION to validate the function
    1970             :  * being created/replaced. The precise behavior of the validator may be
    1971             :  * modified by the check_function_bodies GUC.
    1972             :  */
    1973          42 : PG_FUNCTION_INFO_V1(plperl_validator);
    1974             : 
    1975             : Datum
    1976         292 : plperl_validator(PG_FUNCTION_ARGS)
    1977             : {
    1978         292 :     Oid         funcoid = PG_GETARG_OID(0);
    1979             :     HeapTuple   tuple;
    1980             :     Form_pg_proc proc;
    1981             :     char        functyptype;
    1982             :     int         numargs;
    1983             :     Oid        *argtypes;
    1984             :     char      **argnames;
    1985             :     char       *argmodes;
    1986         292 :     bool        is_trigger = false;
    1987         292 :     bool        is_event_trigger = false;
    1988             :     int         i;
    1989             : 
    1990         292 :     if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid))
    1991           0 :         PG_RETURN_VOID();
    1992             : 
    1993             :     /* Get the new function's pg_proc entry */
    1994         292 :     tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
    1995         292 :     if (!HeapTupleIsValid(tuple))
    1996           0 :         elog(ERROR, "cache lookup failed for function %u", funcoid);
    1997         292 :     proc = (Form_pg_proc) GETSTRUCT(tuple);
    1998             : 
    1999         292 :     functyptype = get_typtype(proc->prorettype);
    2000             : 
    2001             :     /* Disallow pseudotype result */
    2002             :     /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
    2003         292 :     if (functyptype == TYPTYPE_PSEUDO)
    2004             :     {
    2005          76 :         if (proc->prorettype == TRIGGEROID)
    2006          16 :             is_trigger = true;
    2007          60 :         else if (proc->prorettype == EVENT_TRIGGEROID)
    2008           2 :             is_event_trigger = true;
    2009          58 :         else if (proc->prorettype != RECORDOID &&
    2010          36 :                  proc->prorettype != VOIDOID)
    2011           0 :             ereport(ERROR,
    2012             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2013             :                      errmsg("PL/Perl functions cannot return type %s",
    2014             :                             format_type_be(proc->prorettype))));
    2015             :     }
    2016             : 
    2017             :     /* Disallow pseudotypes in arguments (either IN or OUT) */
    2018         292 :     numargs = get_func_arg_info(tuple,
    2019             :                                 &argtypes, &argnames, &argmodes);
    2020         438 :     for (i = 0; i < numargs; i++)
    2021             :     {
    2022         146 :         if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO &&
    2023           2 :             argtypes[i] != RECORDOID)
    2024           0 :             ereport(ERROR,
    2025             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2026             :                      errmsg("PL/Perl functions cannot accept type %s",
    2027             :                             format_type_be(argtypes[i]))));
    2028             :     }
    2029             : 
    2030         292 :     ReleaseSysCache(tuple);
    2031             : 
    2032             :     /* Postpone body checks if !check_function_bodies */
    2033         292 :     if (check_function_bodies)
    2034             :     {
    2035         292 :         (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
    2036             :     }
    2037             : 
    2038             :     /* the result of a validator is ignored */
    2039         286 :     PG_RETURN_VOID();
    2040             : }
    2041             : 
    2042             : 
    2043             : /*
    2044             :  * plperlu likewise requires three externally visible functions:
    2045             :  * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator.
    2046             :  * These are currently just aliases that send control to the plperl
    2047             :  * handler functions, and we decide whether a particular function is
    2048             :  * trusted or not by inspecting the actual pg_language tuple.
    2049             :  */
    2050             : 
    2051          16 : PG_FUNCTION_INFO_V1(plperlu_call_handler);
    2052             : 
    2053             : Datum
    2054         100 : plperlu_call_handler(PG_FUNCTION_ARGS)
    2055             : {
    2056         100 :     return plperl_call_handler(fcinfo);
    2057             : }
    2058             : 
    2059          10 : PG_FUNCTION_INFO_V1(plperlu_inline_handler);
    2060             : 
    2061             : Datum
    2062           2 : plperlu_inline_handler(PG_FUNCTION_ARGS)
    2063             : {
    2064           2 :     return plperl_inline_handler(fcinfo);
    2065             : }
    2066             : 
    2067          18 : PG_FUNCTION_INFO_V1(plperlu_validator);
    2068             : 
    2069             : Datum
    2070          48 : plperlu_validator(PG_FUNCTION_ARGS)
    2071             : {
    2072             :     /* call plperl validator with our fcinfo so it gets our oid */
    2073          48 :     return plperl_validator(fcinfo);
    2074             : }
    2075             : 
    2076             : 
    2077             : /*
    2078             :  * Uses mkfunc to create a subroutine whose text is
    2079             :  * supplied in s, and returns a reference to it
    2080             :  */
    2081             : static void
    2082         330 : plperl_create_sub(plperl_proc_desc *prodesc, const char *s, Oid fn_oid)
    2083             : {
    2084         330 :     dTHX;
    2085         330 :     dSP;
    2086             :     char        subname[NAMEDATALEN + 40];
    2087         330 :     HV         *pragma_hv = newHV();
    2088         330 :     SV         *subref = NULL;
    2089             :     int         count;
    2090             : 
    2091         330 :     sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
    2092             : 
    2093         330 :     if (plperl_use_strict)
    2094           2 :         hv_store_string(pragma_hv, "strict", (SV *) newAV());
    2095             : 
    2096         330 :     ENTER;
    2097         330 :     SAVETMPS;
    2098         330 :     PUSHMARK(SP);
    2099         330 :     EXTEND(SP, 4);
    2100         330 :     PUSHs(sv_2mortal(cstr2sv(subname)));
    2101         330 :     PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
    2102             : 
    2103             :     /*
    2104             :      * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
    2105             :      * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
    2106             :      * compiler.
    2107             :      */
    2108         330 :     PUSHs(&PL_sv_no);
    2109         330 :     PUSHs(sv_2mortal(cstr2sv(s)));
    2110         330 :     PUTBACK;
    2111             : 
    2112             :     /*
    2113             :      * G_KEEPERR seems to be needed here, else we don't recognize compile
    2114             :      * errors properly.  Perhaps it's because there's another level of eval
    2115             :      * inside mksafefunc?
    2116             :      */
    2117         330 :     count = call_pv("PostgreSQL::InServer::mkfunc",
    2118             :                     G_SCALAR | G_EVAL | G_KEEPERR);
    2119         330 :     SPAGAIN;
    2120             : 
    2121         330 :     if (count == 1)
    2122             :     {
    2123         330 :         SV         *sub_rv = (SV *) POPs;
    2124             : 
    2125         330 :         if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
    2126             :         {
    2127         314 :             subref = newRV_inc(SvRV(sub_rv));
    2128             :         }
    2129             :     }
    2130             : 
    2131         330 :     PUTBACK;
    2132         330 :     FREETMPS;
    2133         330 :     LEAVE;
    2134             : 
    2135         330 :     if (SvTRUE(ERRSV))
    2136          16 :         ereport(ERROR,
    2137             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    2138             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2139             : 
    2140         314 :     if (!subref)
    2141           0 :         ereport(ERROR,
    2142             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    2143             :                  errmsg("didn't get a CODE reference from compiling function \"%s\"",
    2144             :                         prodesc->proname)));
    2145             : 
    2146         314 :     prodesc->reference = subref;
    2147         314 : }
    2148             : 
    2149             : 
    2150             : /**********************************************************************
    2151             :  * plperl_init_shared_libs()        -
    2152             :  **********************************************************************/
    2153             : 
    2154             : static void
    2155          44 : plperl_init_shared_libs(pTHX)
    2156             : {
    2157          44 :     char       *file = __FILE__;
    2158             : 
    2159          44 :     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    2160          44 :     newXS("PostgreSQL::InServer::Util::bootstrap",
    2161             :           boot_PostgreSQL__InServer__Util, file);
    2162             :     /* newXS for...::SPI::bootstrap is in select_perl_context() */
    2163          44 : }
    2164             : 
    2165             : 
    2166             : static SV  *
    2167         482 : plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
    2168             : {
    2169         482 :     dTHX;
    2170         482 :     dSP;
    2171             :     SV         *retval;
    2172             :     int         i;
    2173             :     int         count;
    2174         482 :     Oid        *argtypes = NULL;
    2175         482 :     int         nargs = 0;
    2176             : 
    2177         482 :     ENTER;
    2178         482 :     SAVETMPS;
    2179             : 
    2180         482 :     PUSHMARK(SP);
    2181         482 :     EXTEND(sp, desc->nargs);
    2182             : 
    2183             :     /* Get signature for true functions; inline blocks have no args. */
    2184         482 :     if (fcinfo->flinfo->fn_oid)
    2185         454 :         get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs);
    2186             :     Assert(nargs == desc->nargs);
    2187             : 
    2188         866 :     for (i = 0; i < desc->nargs; i++)
    2189             :     {
    2190         384 :         if (fcinfo->args[i].isnull)
    2191           8 :             PUSHs(&PL_sv_undef);
    2192         376 :         else if (desc->arg_is_rowtype[i])
    2193             :         {
    2194          22 :             SV         *sv = plperl_hash_from_datum(fcinfo->args[i].value);
    2195             : 
    2196          22 :             PUSHs(sv_2mortal(sv));
    2197             :         }
    2198             :         else
    2199             :         {
    2200             :             SV         *sv;
    2201             :             Oid         funcid;
    2202             : 
    2203         354 :             if (OidIsValid(desc->arg_arraytype[i]))
    2204          26 :                 sv = plperl_ref_from_pg_array(fcinfo->args[i].value, desc->arg_arraytype[i]);
    2205         328 :             else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
    2206         114 :                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->args[i].value));
    2207             :             else
    2208             :             {
    2209             :                 char       *tmp;
    2210             : 
    2211         214 :                 tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
    2212             :                                          fcinfo->args[i].value);
    2213         214 :                 sv = cstr2sv(tmp);
    2214         214 :                 pfree(tmp);
    2215             :             }
    2216             : 
    2217         354 :             PUSHs(sv_2mortal(sv));
    2218             :         }
    2219             :     }
    2220         482 :     PUTBACK;
    2221             : 
    2222             :     /* Do NOT use G_KEEPERR here */
    2223         482 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2224             : 
    2225         480 :     SPAGAIN;
    2226             : 
    2227         480 :     if (count != 1)
    2228             :     {
    2229           0 :         PUTBACK;
    2230           0 :         FREETMPS;
    2231           0 :         LEAVE;
    2232           0 :         ereport(ERROR,
    2233             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2234             :                  errmsg("didn't get a return item from function")));
    2235             :     }
    2236             : 
    2237         480 :     if (SvTRUE(ERRSV))
    2238             :     {
    2239          36 :         (void) POPs;
    2240          36 :         PUTBACK;
    2241          36 :         FREETMPS;
    2242          36 :         LEAVE;
    2243             :         /* XXX need to find a way to determine a better errcode here */
    2244          36 :         ereport(ERROR,
    2245             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2246             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2247             :     }
    2248             : 
    2249         444 :     retval = newSVsv(POPs);
    2250             : 
    2251         444 :     PUTBACK;
    2252         444 :     FREETMPS;
    2253         444 :     LEAVE;
    2254             : 
    2255         444 :     return retval;
    2256             : }
    2257             : 
    2258             : 
    2259             : static SV  *
    2260          60 : plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
    2261             :                               SV *td)
    2262             : {
    2263          60 :     dTHX;
    2264          60 :     dSP;
    2265             :     SV         *retval,
    2266             :                *TDsv;
    2267             :     int         i,
    2268             :                 count;
    2269          60 :     Trigger    *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
    2270             : 
    2271          60 :     ENTER;
    2272          60 :     SAVETMPS;
    2273             : 
    2274          60 :     TDsv = get_sv("main::_TD", 0);
    2275          60 :     if (!TDsv)
    2276           0 :         ereport(ERROR,
    2277             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2278             :                  errmsg("couldn't fetch $_TD")));
    2279             : 
    2280          60 :     save_item(TDsv);            /* local $_TD */
    2281          60 :     sv_setsv(TDsv, td);
    2282             : 
    2283          60 :     PUSHMARK(sp);
    2284          60 :     EXTEND(sp, tg_trigger->tgnargs);
    2285             : 
    2286          96 :     for (i = 0; i < tg_trigger->tgnargs; i++)
    2287          36 :         PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
    2288          60 :     PUTBACK;
    2289             : 
    2290             :     /* Do NOT use G_KEEPERR here */
    2291          60 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2292             : 
    2293          60 :     SPAGAIN;
    2294             : 
    2295          60 :     if (count != 1)
    2296             :     {
    2297           0 :         PUTBACK;
    2298           0 :         FREETMPS;
    2299           0 :         LEAVE;
    2300           0 :         ereport(ERROR,
    2301             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2302             :                  errmsg("didn't get a return item from trigger function")));
    2303             :     }
    2304             : 
    2305          60 :     if (SvTRUE(ERRSV))
    2306             :     {
    2307           0 :         (void) POPs;
    2308           0 :         PUTBACK;
    2309           0 :         FREETMPS;
    2310           0 :         LEAVE;
    2311             :         /* XXX need to find a way to determine a better errcode here */
    2312           0 :         ereport(ERROR,
    2313             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2314             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2315             :     }
    2316             : 
    2317          60 :     retval = newSVsv(POPs);
    2318             : 
    2319          60 :     PUTBACK;
    2320          60 :     FREETMPS;
    2321          60 :     LEAVE;
    2322             : 
    2323          60 :     return retval;
    2324             : }
    2325             : 
    2326             : 
    2327             : static void
    2328          20 : plperl_call_perl_event_trigger_func(plperl_proc_desc *desc,
    2329             :                                     FunctionCallInfo fcinfo,
    2330             :                                     SV *td)
    2331             : {
    2332          20 :     dTHX;
    2333          20 :     dSP;
    2334             :     SV         *retval,
    2335             :                *TDsv;
    2336             :     int         count;
    2337             : 
    2338          20 :     ENTER;
    2339          20 :     SAVETMPS;
    2340             : 
    2341          20 :     TDsv = get_sv("main::_TD", 0);
    2342          20 :     if (!TDsv)
    2343           0 :         ereport(ERROR,
    2344             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2345             :                  errmsg("couldn't fetch $_TD")));
    2346             : 
    2347          20 :     save_item(TDsv);            /* local $_TD */
    2348          20 :     sv_setsv(TDsv, td);
    2349             : 
    2350          20 :     PUSHMARK(sp);
    2351          20 :     PUTBACK;
    2352             : 
    2353             :     /* Do NOT use G_KEEPERR here */
    2354          20 :     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
    2355             : 
    2356          20 :     SPAGAIN;
    2357             : 
    2358          20 :     if (count != 1)
    2359             :     {
    2360           0 :         PUTBACK;
    2361           0 :         FREETMPS;
    2362           0 :         LEAVE;
    2363           0 :         ereport(ERROR,
    2364             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2365             :                  errmsg("didn't get a return item from trigger function")));
    2366             :     }
    2367             : 
    2368          20 :     if (SvTRUE(ERRSV))
    2369             :     {
    2370           0 :         (void) POPs;
    2371           0 :         PUTBACK;
    2372           0 :         FREETMPS;
    2373           0 :         LEAVE;
    2374             :         /* XXX need to find a way to determine a better errcode here */
    2375           0 :         ereport(ERROR,
    2376             :                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
    2377             :                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
    2378             :     }
    2379             : 
    2380          20 :     retval = newSVsv(POPs);
    2381             :     (void) retval;              /* silence compiler warning */
    2382             : 
    2383          20 :     PUTBACK;
    2384          20 :     FREETMPS;
    2385          20 :     LEAVE;
    2386          20 : }
    2387             : 
    2388             : static Datum
    2389         456 : plperl_func_handler(PG_FUNCTION_ARGS)
    2390             : {
    2391             :     bool        nonatomic;
    2392             :     plperl_proc_desc *prodesc;
    2393             :     SV         *perlret;
    2394         456 :     Datum       retval = 0;
    2395             :     ReturnSetInfo *rsi;
    2396             :     ErrorContextCallback pl_error_context;
    2397             : 
    2398         928 :     nonatomic = fcinfo->context &&
    2399         472 :         IsA(fcinfo->context, CallContext) &&
    2400          16 :         !castNode(CallContext, fcinfo->context)->atomic;
    2401             : 
    2402         456 :     if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT)
    2403           0 :         elog(ERROR, "could not connect to SPI manager");
    2404             : 
    2405         456 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
    2406         454 :     current_call_data->prodesc = prodesc;
    2407         454 :     increment_prodesc_refcount(prodesc);
    2408             : 
    2409             :     /* Set a callback for error reporting */
    2410         454 :     pl_error_context.callback = plperl_exec_callback;
    2411         454 :     pl_error_context.previous = error_context_stack;
    2412         454 :     pl_error_context.arg = prodesc->proname;
    2413         454 :     error_context_stack = &pl_error_context;
    2414             : 
    2415         454 :     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
    2416             : 
    2417         454 :     if (prodesc->fn_retisset)
    2418             :     {
    2419             :         /* Check context before allowing the call to go through */
    2420          86 :         if (!rsi || !IsA(rsi, ReturnSetInfo))
    2421           0 :             ereport(ERROR,
    2422             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2423             :                      errmsg("set-valued function called in context that cannot accept a set")));
    2424             : 
    2425          86 :         if (!(rsi->allowedModes & SFRM_Materialize))
    2426           0 :             ereport(ERROR,
    2427             :                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2428             :                      errmsg("materialize mode required, but it is not allowed in this context")));
    2429             :     }
    2430             : 
    2431         454 :     activate_interpreter(prodesc->interp);
    2432             : 
    2433         454 :     perlret = plperl_call_perl_func(prodesc, fcinfo);
    2434             : 
    2435             :     /************************************************************
    2436             :      * Disconnect from SPI manager and then create the return
    2437             :      * values datum (if the input function does a palloc for it
    2438             :      * this must not be allocated in the SPI memory context
    2439             :      * because SPI_finish would free it).
    2440             :      ************************************************************/
    2441         426 :     if (SPI_finish() != SPI_OK_FINISH)
    2442           0 :         elog(ERROR, "SPI_finish() failed");
    2443             : 
    2444         426 :     if (prodesc->fn_retisset)
    2445             :     {
    2446             :         SV         *sav;
    2447             : 
    2448             :         /*
    2449             :          * If the Perl function returned an arrayref, we pretend that it
    2450             :          * called return_next() for each element of the array, to handle old
    2451             :          * SRFs that didn't know about return_next(). Any other sort of return
    2452             :          * value is an error, except undef which means return an empty set.
    2453             :          */
    2454          84 :         sav = get_perl_array_ref(perlret);
    2455          84 :         if (sav)
    2456             :         {
    2457          36 :             dTHX;
    2458          36 :             int         i = 0;
    2459          36 :             SV        **svp = 0;
    2460          36 :             AV         *rav = (AV *) SvRV(sav);
    2461             : 
    2462         128 :             while ((svp = av_fetch(rav, i, FALSE)) != NULL)
    2463             :             {
    2464         108 :                 plperl_return_next_internal(*svp);
    2465          92 :                 i++;
    2466             :             }
    2467             :         }
    2468          48 :         else if (SvOK(perlret))
    2469             :         {
    2470           4 :             ereport(ERROR,
    2471             :                     (errcode(ERRCODE_DATATYPE_MISMATCH),
    2472             :                      errmsg("set-returning PL/Perl function must return "
    2473             :                             "reference to array or use return_next")));
    2474             :         }
    2475             : 
    2476          64 :         rsi->returnMode = SFRM_Materialize;
    2477          64 :         if (current_call_data->tuple_store)
    2478             :         {
    2479          52 :             rsi->setResult = current_call_data->tuple_store;
    2480          52 :             rsi->setDesc = current_call_data->ret_tdesc;
    2481             :         }
    2482          64 :         retval = (Datum) 0;
    2483             :     }
    2484         342 :     else if (prodesc->result_oid)
    2485             :     {
    2486         342 :         retval = plperl_sv_to_datum(perlret,
    2487             :                                     prodesc->result_oid,
    2488             :                                     -1,
    2489             :                                     fcinfo,
    2490             :                                     &prodesc->result_in_func,
    2491             :                                     prodesc->result_typioparam,
    2492             :                                     &fcinfo->isnull);
    2493             : 
    2494         318 :         if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
    2495           6 :             rsi->isDone = ExprEndResult;
    2496             :     }
    2497             : 
    2498             :     /* Restore the previous error callback */
    2499         382 :     error_context_stack = pl_error_context.previous;
    2500             : 
    2501         382 :     SvREFCNT_dec_current(perlret);
    2502             : 
    2503         382 :     return retval;
    2504             : }
    2505             : 
    2506             : 
    2507             : static Datum
    2508          60 : plperl_trigger_handler(PG_FUNCTION_ARGS)
    2509             : {
    2510             :     plperl_proc_desc *prodesc;
    2511             :     SV         *perlret;
    2512             :     Datum       retval;
    2513             :     SV         *svTD;
    2514             :     HV         *hvTD;
    2515             :     ErrorContextCallback pl_error_context;
    2516             :     TriggerData *tdata;
    2517             :     int         rc PG_USED_FOR_ASSERTS_ONLY;
    2518             : 
    2519             :     /* Connect to SPI manager */
    2520          60 :     if (SPI_connect() != SPI_OK_CONNECT)
    2521           0 :         elog(ERROR, "could not connect to SPI manager");
    2522             : 
    2523             :     /* Make transition tables visible to this SPI connection */
    2524          60 :     tdata = (TriggerData *) fcinfo->context;
    2525          60 :     rc = SPI_register_trigger_data(tdata);
    2526             :     Assert(rc >= 0);
    2527             : 
    2528             :     /* Find or compile the function */
    2529          60 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
    2530          60 :     current_call_data->prodesc = prodesc;
    2531          60 :     increment_prodesc_refcount(prodesc);
    2532             : 
    2533             :     /* Set a callback for error reporting */
    2534          60 :     pl_error_context.callback = plperl_exec_callback;
    2535          60 :     pl_error_context.previous = error_context_stack;
    2536          60 :     pl_error_context.arg = prodesc->proname;
    2537          60 :     error_context_stack = &pl_error_context;
    2538             : 
    2539          60 :     activate_interpreter(prodesc->interp);
    2540             : 
    2541          60 :     svTD = plperl_trigger_build_args(fcinfo);
    2542          60 :     perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
    2543          60 :     hvTD = (HV *) SvRV(svTD);
    2544             : 
    2545             :     /************************************************************
    2546             :     * Disconnect from SPI manager and then create the return
    2547             :     * values datum (if the input function does a palloc for it
    2548             :     * this must not be allocated in the SPI memory context
    2549             :     * because SPI_finish would free it).
    2550             :     ************************************************************/
    2551          60 :     if (SPI_finish() != SPI_OK_FINISH)
    2552           0 :         elog(ERROR, "SPI_finish() failed");
    2553             : 
    2554          60 :     if (perlret == NULL || !SvOK(perlret))
    2555          42 :     {
    2556             :         /* undef result means go ahead with original tuple */
    2557          42 :         TriggerData *trigdata = ((TriggerData *) fcinfo->context);
    2558             : 
    2559          42 :         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    2560          14 :             retval = (Datum) trigdata->tg_trigtuple;
    2561          28 :         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    2562          10 :             retval = (Datum) trigdata->tg_newtuple;
    2563          18 :         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
    2564          18 :             retval = (Datum) trigdata->tg_trigtuple;
    2565           0 :         else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
    2566           0 :             retval = (Datum) trigdata->tg_trigtuple;
    2567             :         else
    2568           0 :             retval = (Datum) 0; /* can this happen? */
    2569             :     }
    2570             :     else
    2571             :     {
    2572             :         HeapTuple   trv;
    2573             :         char       *tmp;
    2574             : 
    2575          18 :         tmp = sv2cstr(perlret);
    2576             : 
    2577          18 :         if (pg_strcasecmp(tmp, "SKIP") == 0)
    2578           6 :             trv = NULL;
    2579          12 :         else if (pg_strcasecmp(tmp, "MODIFY") == 0)
    2580             :         {
    2581          12 :             TriggerData *trigdata = (TriggerData *) fcinfo->context;
    2582             : 
    2583          12 :             if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
    2584           8 :                 trv = plperl_modify_tuple(hvTD, trigdata,
    2585             :                                           trigdata->tg_trigtuple);
    2586           4 :             else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
    2587           4 :                 trv = plperl_modify_tuple(hvTD, trigdata,
    2588             :                                           trigdata->tg_newtuple);
    2589             :             else
    2590             :             {
    2591           0 :                 ereport(WARNING,
    2592             :                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    2593             :                          errmsg("ignoring modified row in DELETE trigger")));
    2594           0 :                 trv = NULL;
    2595             :             }
    2596             :         }
    2597             :         else
    2598             :         {
    2599           0 :             ereport(ERROR,
    2600             :                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
    2601             :                      errmsg("result of PL/Perl trigger function must be undef, "
    2602             :                             "\"SKIP\", or \"MODIFY\"")));
    2603             :             trv = NULL;
    2604             :         }
    2605          16 :         retval = PointerGetDatum(trv);
    2606          16 :         pfree(tmp);
    2607             :     }
    2608             : 
    2609             :     /* Restore the previous error callback */
    2610          58 :     error_context_stack = pl_error_context.previous;
    2611             : 
    2612          58 :     SvREFCNT_dec_current(svTD);
    2613          58 :     if (perlret)
    2614          58 :         SvREFCNT_dec_current(perlret);
    2615             : 
    2616          58 :     return retval;
    2617             : }
    2618             : 
    2619             : 
    2620             : static void
    2621          20 : plperl_event_trigger_handler(PG_FUNCTION_ARGS)
    2622             : {
    2623             :     plperl_proc_desc *prodesc;
    2624             :     SV         *svTD;
    2625             :     ErrorContextCallback pl_error_context;
    2626             : 
    2627             :     /* Connect to SPI manager */
    2628          20 :     if (SPI_connect() != SPI_OK_CONNECT)
    2629           0 :         elog(ERROR, "could not connect to SPI manager");
    2630             : 
    2631             :     /* Find or compile the function */
    2632          20 :     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
    2633          20 :     current_call_data->prodesc = prodesc;
    2634          20 :     increment_prodesc_refcount(prodesc);
    2635             : 
    2636             :     /* Set a callback for error reporting */
    2637          20 :     pl_error_context.callback = plperl_exec_callback;
    2638          20 :     pl_error_context.previous = error_context_stack;
    2639          20 :     pl_error_context.arg = prodesc->proname;
    2640          20 :     error_context_stack = &pl_error_context;
    2641             : 
    2642          20 :     activate_interpreter(prodesc->interp);
    2643             : 
    2644          20 :     svTD = plperl_event_trigger_build_args(fcinfo);
    2645          20 :     plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
    2646             : 
    2647          20 :     if (SPI_finish() != SPI_OK_FINISH)
    2648           0 :         elog(ERROR, "SPI_finish() failed");
    2649             : 
    2650             :     /* Restore the previous error callback */
    2651          20 :     error_context_stack = pl_error_context.previous;
    2652             : 
    2653          20 :     SvREFCNT_dec_current(svTD);
    2654          20 : }
    2655             : 
    2656             : 
    2657             : static bool
    2658        1222 : validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
    2659             : {
    2660        1222 :     if (proc_ptr && proc_ptr->proc_ptr)
    2661             :     {
    2662         580 :         plperl_proc_desc *prodesc = proc_ptr->proc_ptr;
    2663             :         bool        uptodate;
    2664             : 
    2665             :         /************************************************************
    2666             :          * If it's present, must check whether it's still up to date.
    2667             :          * This is needed because CREATE OR REPLACE FUNCTION can modify the
    2668             :          * function's pg_proc entry without changing its OID.
    2669             :          ************************************************************/
    2670        1114 :         uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
    2671         534 :                     ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
    2672             : 
    2673         580 :         if (uptodate)
    2674         534 :             return true;
    2675             : 
    2676             :         /* Otherwise, unlink the obsoleted entry from the hashtable ... */
    2677          46 :         proc_ptr->proc_ptr = NULL;
    2678             :         /* ... and release the corresponding refcount, probably deleting it */
    2679          46 :         decrement_prodesc_refcount(prodesc);
    2680             :     }
    2681             : 
    2682         688 :     return false;
    2683             : }
    2684             : 
    2685             : 
    2686             : static void
    2687          46 : free_plperl_function(plperl_proc_desc *prodesc)
    2688             : {
    2689             :     Assert(prodesc->fn_refcount == 0);
    2690             :     /* Release CODE reference, if we have one, from the appropriate interp */
    2691          46 :     if (prodesc->reference)
    2692             :     {
    2693          46 :         plperl_interp_desc *oldinterp = plperl_active_interp;
    2694             : 
    2695          46 :         activate_interpreter(prodesc->interp);
    2696          46 :         SvREFCNT_dec_current(prodesc->reference);
    2697          46 :         activate_interpreter(oldinterp);
    2698             :     }
    2699             :     /* Release all PG-owned data for this proc */
    2700          46 :     MemoryContextDelete(prodesc->fn_cxt);
    2701          46 : }
    2702             : 
    2703             : 
    2704             : static plperl_proc_desc *
    2705         828 : compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
    2706             : {
    2707             :     HeapTuple   procTup;
    2708             :     Form_pg_proc procStruct;
    2709             :     plperl_proc_key proc_key;
    2710             :     plperl_proc_ptr *proc_ptr;
    2711         828 :     plperl_proc_desc *volatile prodesc = NULL;
    2712         828 :     volatile MemoryContext proc_cxt = NULL;
    2713         828 :     plperl_interp_desc *oldinterp = plperl_active_interp;
    2714             :     ErrorContextCallback plperl_error_context;
    2715             : 
    2716             :     /* We'll need the pg_proc tuple in any case... */
    2717         828 :     procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
    2718         828 :     if (!HeapTupleIsValid(procTup))
    2719           0 :         elog(ERROR, "cache lookup failed for function %u", fn_oid);
    2720         828 :     procStruct = (Form_pg_proc) GETSTRUCT(procTup);
    2721             : 
    2722             :     /*
    2723             :      * Try to find function in plperl_proc_hash.  The reason for this
    2724             :      * overcomplicated-seeming lookup procedure is that we don't know whether
    2725             :      * it's plperl or plperlu, and don't want to spend a lookup in pg_language
    2726             :      * to find out.
    2727             :      */
    2728         828 :     proc_key.proc_id = fn_oid;
    2729         828 :     proc_key.is_trigger = is_trigger;
    2730         828 :     proc_key.user_id = GetUserId();
    2731         828 :     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2732             :                            HASH_FIND, NULL);
    2733         828 :     if (validate_plperl_function(proc_ptr, procTup))
    2734             :     {
    2735             :         /* Found valid plperl entry */
    2736         434 :         ReleaseSysCache(procTup);
    2737         434 :         return proc_ptr->proc_ptr;
    2738             :     }
    2739             : 
    2740             :     /* If not found or obsolete, maybe it's plperlu */
    2741         394 :     proc_key.user_id = InvalidOid;
    2742         394 :     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2743             :                            HASH_FIND, NULL);
    2744         394 :     if (validate_plperl_function(proc_ptr, procTup))
    2745             :     {
    2746             :         /* Found valid plperlu entry */
    2747         100 :         ReleaseSysCache(procTup);
    2748         100 :         return proc_ptr->proc_ptr;
    2749             :     }
    2750             : 
    2751             :     /************************************************************
    2752             :      * If we haven't found it in the hashtable, we analyze
    2753             :      * the function's arguments and return type and store
    2754             :      * the in-/out-functions in the prodesc block,
    2755             :      * then we load the procedure into the Perl interpreter,
    2756             :      * and last we create a new hashtable entry for it.
    2757             :      ************************************************************/
    2758             : 
    2759             :     /* Set a callback for reporting compilation errors */
    2760         294 :     plperl_error_context.callback = plperl_compile_callback;
    2761         294 :     plperl_error_context.previous = error_context_stack;
    2762         294 :     plperl_error_context.arg = NameStr(procStruct->proname);
    2763         294 :     error_context_stack = &plperl_error_context;
    2764             : 
    2765         294 :     PG_TRY();
    2766             :     {
    2767             :         HeapTuple   langTup;
    2768             :         HeapTuple   typeTup;
    2769             :         Form_pg_language langStruct;
    2770             :         Form_pg_type typeStruct;
    2771             :         Datum       protrftypes_datum;
    2772             :         Datum       prosrcdatum;
    2773             :         bool        isnull;
    2774             :         char       *proc_source;
    2775             :         MemoryContext oldcontext;
    2776             : 
    2777             :         /************************************************************
    2778             :          * Allocate a context that will hold all PG data for the procedure.
    2779             :          ************************************************************/
    2780         294 :         proc_cxt = AllocSetContextCreate(TopMemoryContext,
    2781             :                                          "PL/Perl function",
    2782             :                                          ALLOCSET_SMALL_SIZES);
    2783             : 
    2784             :         /************************************************************
    2785             :          * Allocate and fill a new procedure description block.
    2786             :          * struct prodesc and subsidiary data must all live in proc_cxt.
    2787             :          ************************************************************/
    2788         294 :         oldcontext = MemoryContextSwitchTo(proc_cxt);
    2789         294 :         prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc));
    2790         294 :         prodesc->proname = pstrdup(NameStr(procStruct->proname));
    2791         294 :         MemoryContextSetIdentifier(proc_cxt, prodesc->proname);
    2792         294 :         prodesc->fn_cxt = proc_cxt;
    2793         294 :         prodesc->fn_refcount = 0;
    2794         294 :         prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
    2795         294 :         prodesc->fn_tid = procTup->t_self;
    2796         294 :         prodesc->nargs = procStruct->pronargs;
    2797         294 :         prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
    2798         294 :         prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
    2799         294 :         prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid));
    2800         294 :         MemoryContextSwitchTo(oldcontext);
    2801             : 
    2802             :         /* Remember if function is STABLE/IMMUTABLE */
    2803         294 :         prodesc->fn_readonly =
    2804         294 :             (procStruct->provolatile != PROVOLATILE_VOLATILE);
    2805             : 
    2806             :         /* Fetch protrftypes */
    2807         294 :         protrftypes_datum = SysCacheGetAttr(PROCOID, procTup,
    2808             :                                             Anum_pg_proc_protrftypes, &isnull);
    2809         294 :         MemoryContextSwitchTo(proc_cxt);
    2810         294 :         prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum);
    2811         294 :         MemoryContextSwitchTo(oldcontext);
    2812             : 
    2813             :         /************************************************************
    2814             :          * Lookup the pg_language tuple by Oid
    2815             :          ************************************************************/
    2816         588 :         langTup = SearchSysCache1(LANGOID,
    2817         294 :                                   ObjectIdGetDatum(procStruct->prolang));
    2818         294 :         if (!HeapTupleIsValid(langTup))
    2819           0 :             elog(ERROR, "cache lookup failed for language %u",
    2820             :                  procStruct->prolang);
    2821         294 :         langStruct = (Form_pg_language) GETSTRUCT(langTup);
    2822         294 :         prodesc->lang_oid = langStruct->oid;
    2823         294 :         prodesc->lanpltrusted = langStruct->lanpltrusted;
    2824         294 :         ReleaseSysCache(langTup);
    2825             : 
    2826             :         /************************************************************
    2827             :          * Get the required information for input conversion of the
    2828             :          * return value.
    2829             :          ************************************************************/
    2830         294 :         if (!is_trigger && !is_event_trigger)
    2831             :         {
    2832         276 :             Oid         rettype = procStruct->prorettype;
    2833             : 
    2834         276 :             typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
    2835         276 :             if (!HeapTupleIsValid(typeTup))
    2836           0 :                 elog(ERROR, "cache lookup failed for type %u", rettype);
    2837         276 :             typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    2838             : 
    2839             :             /* Disallow pseudotype result, except VOID or RECORD */
    2840         276 :             if (typeStruct->typtype == TYPTYPE_PSEUDO)
    2841             :             {
    2842          60 :                 if (rettype == VOIDOID ||
    2843             :                     rettype == RECORDOID)
    2844             :                      /* okay */ ;
    2845           2 :                 else if (rettype == TRIGGEROID ||
    2846             :                          rettype == EVENT_TRIGGEROID)
    2847           2 :                     ereport(ERROR,
    2848             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2849             :                              errmsg("trigger functions can only be called "
    2850             :                                     "as triggers")));
    2851             :                 else
    2852           0 :                     ereport(ERROR,
    2853             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2854             :                              errmsg("PL/Perl functions cannot return type %s",
    2855             :                                     format_type_be(rettype))));
    2856             :             }
    2857             : 
    2858         274 :             prodesc->result_oid = rettype;
    2859         274 :             prodesc->fn_retisset = procStruct->proretset;
    2860         274 :             prodesc->fn_retistuple = type_is_rowtype(rettype);
    2861         274 :             prodesc->fn_retisarray = IsTrueArrayType(typeStruct);
    2862             : 
    2863         274 :             fmgr_info_cxt(typeStruct->typinput,
    2864         274 :                           &(prodesc->result_in_func),
    2865             :                           proc_cxt);
    2866         274 :             prodesc->result_typioparam = getTypeIOParam(typeTup);
    2867             : 
    2868         274 :             ReleaseSysCache(typeTup);
    2869             :         }
    2870             : 
    2871             :         /************************************************************
    2872             :          * Get the required information for output conversion
    2873             :          * of all procedure arguments
    2874             :          ************************************************************/
    2875         292 :         if (!is_trigger && !is_event_trigger)
    2876             :         {
    2877             :             int         i;
    2878             : 
    2879         404 :             for (i = 0; i < prodesc->nargs; i++)
    2880             :             {
    2881         130 :                 Oid         argtype = procStruct->proargtypes.values[i];
    2882             : 
    2883         130 :                 typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
    2884         130 :                 if (!HeapTupleIsValid(typeTup))
    2885           0 :                     elog(ERROR, "cache lookup failed for type %u", argtype);
    2886         130 :                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
    2887             : 
    2888             :                 /* Disallow pseudotype argument, except RECORD */
    2889         130 :                 if (typeStruct->typtype == TYPTYPE_PSEUDO &&
    2890             :                     argtype != RECORDOID)
    2891           0 :                     ereport(ERROR,
    2892             :                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    2893             :                              errmsg("PL/Perl functions cannot accept type %s",
    2894             :                                     format_type_be(argtype))));
    2895             : 
    2896         130 :                 if (type_is_rowtype(argtype))
    2897          12 :                     prodesc->arg_is_rowtype[i] = true;
    2898             :                 else
    2899             :                 {
    2900         118 :                     prodesc->arg_is_rowtype[i] = false;
    2901         118 :                     fmgr_info_cxt(typeStruct->typoutput,
    2902         118 :                                   &(prodesc->arg_out_func[i]),
    2903             :                                   proc_cxt);
    2904             :                 }
    2905             : 
    2906             :                 /* Identify array-type arguments */
    2907         130 :                 if (IsTrueArrayType(typeStruct))
    2908          14 :                     prodesc->arg_arraytype[i] = argtype;
    2909             :                 else
    2910         116 :                     prodesc->arg_arraytype[i] = InvalidOid;
    2911             : 
    2912         130 :                 ReleaseSysCache(typeTup);
    2913             :             }
    2914             :         }
    2915             : 
    2916             :         /************************************************************
    2917             :          * create the text of the anonymous subroutine.
    2918             :          * we do not use a named subroutine so that we can call directly
    2919             :          * through the reference.
    2920             :          ************************************************************/
    2921         292 :         prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
    2922             :                                       Anum_pg_proc_prosrc, &isnull);
    2923         292 :         if (isnull)
    2924           0 :             elog(ERROR, "null prosrc");
    2925         292 :         proc_source = TextDatumGetCString(prosrcdatum);
    2926             : 
    2927             :         /************************************************************
    2928             :          * Create the procedure in the appropriate interpreter
    2929             :          ************************************************************/
    2930             : 
    2931         292 :         select_perl_context(prodesc->lanpltrusted);
    2932             : 
    2933         292 :         prodesc->interp = plperl_active_interp;
    2934             : 
    2935         292 :         plperl_create_sub(prodesc, proc_source, fn_oid);
    2936             : 
    2937         286 :         activate_interpreter(oldinterp);
    2938             : 
    2939         286 :         pfree(proc_source);
    2940             : 
    2941         286 :         if (!prodesc->reference) /* can this happen? */
    2942           0 :             elog(ERROR, "could not create PL/Perl internal procedure");
    2943             : 
    2944             :         /************************************************************
    2945             :          * OK, link the procedure into the correct hashtable entry.
    2946             :          * Note we assume that the hashtable entry either doesn't exist yet,
    2947             :          * or we already cleared its proc_ptr during the validation attempts
    2948             :          * above.  So no need to decrement an old refcount here.
    2949             :          ************************************************************/
    2950         286 :         proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
    2951             : 
    2952         286 :         proc_ptr = hash_search(plperl_proc_hash, &proc_key,
    2953             :                                HASH_ENTER, NULL);
    2954             :         /* We assume these two steps can't throw an error: */
    2955         286 :         proc_ptr->proc_ptr = prodesc;
    2956         286 :         increment_prodesc_refcount(prodesc);
    2957             :     }
    2958           8 :     PG_CATCH();
    2959             :     {
    2960             :         /*
    2961             :          * If we got as far as creating a reference, we should be able to use
    2962             :          * free_plperl_function() to clean up.  If not, then at most we have
    2963             :          * some PG memory resources in proc_cxt, which we can just delete.
    2964             :          */
    2965           8 :         if (prodesc && prodesc->reference)
    2966           0 :             free_plperl_function(prodesc);
    2967           8 :         else if (proc_cxt)
    2968           8 :             MemoryContextDelete(proc_cxt);
    2969             : 
    2970             :         /* Be sure to restore the previous interpreter, too, for luck */
    2971           8 :         activate_interpreter(oldinterp);
    2972             : 
    2973           8 :         PG_RE_THROW();
    2974             :     }
    2975         286 :     PG_END_TRY();
    2976             : 
    2977             :     /* restore previous error callback */
    2978         286 :     error_context_stack = plperl_error_context.previous;
    2979             : 
    2980         286 :     ReleaseSysCache(procTup);
    2981             : 
    2982         286 :     return prodesc;
    2983             : }
    2984             : 
    2985             : /* Build a hash from a given composite/row datum */
    2986             : static SV  *
    2987         114 : plperl_hash_from_datum(Datum attr)
    2988             : {
    2989             :     HeapTupleHeader td;
    2990             :     Oid         tupType;
    2991             :     int32       tupTypmod;
    2992             :     TupleDesc   tupdesc;
    2993             :     HeapTupleData tmptup;
    2994             :     SV         *sv;
    2995             : 
    2996         114 :     td = DatumGetHeapTupleHeader(attr);
    2997             : 
    2998             :     /* Extract rowtype info and find a tupdesc */
    2999         114 :     tupType = HeapTupleHeaderGetTypeId(td);
    3000         114 :     tupTypmod = HeapTupleHeaderGetTypMod(td);
    3001         114 :     tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
    3002             : 
    3003             :     /* Build a temporary HeapTuple control structure */
    3004         114 :     tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
    3005         114 :     tmptup.t_data = td;
    3006             : 
    3007         114 :     sv = plperl_hash_from_tuple(&tmptup, tupdesc, true);
    3008         114 :     ReleaseTupleDesc(tupdesc);
    3009             : 
    3010         114 :     return sv;
    3011             : }
    3012             : 
    3013             : /* Build a hash from all attributes of a given tuple. */
    3014             : static SV  *
    3015         260 : plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc, bool include_generated)
    3016             : {
    3017         260 :     dTHX;
    3018             :     HV         *hv;
    3019             :     int         i;
    3020             : 
    3021             :     /* since this function recurses, it could be driven to stack overflow */
    3022         260 :     check_stack_depth();
    3023             : 
    3024         260 :     hv = newHV();
    3025         260 :     hv_ksplit(hv, tupdesc->natts);   /* pre-grow the hash */
    3026             : 
    3027         686 :     for (i = 0; i < tupdesc->natts; i++)
    3028             :     {
    3029             :         Datum       attr;
    3030             :         bool        isnull,
    3031             :                     typisvarlena;
    3032             :         char       *attname;
    3033             :         Oid         typoutput;
    3034         426 :         Form_pg_attribute att = TupleDescAttr(tupdesc, i);
    3035             : 
    3036         426 :         if (att->attisdropped)
    3037          20 :             continue;
    3038             : 
    3039         426 :         if (att->attgenerated)
    3040             :         {
    3041             :             /* don't include unless requested */
    3042          18 :             if (!include_generated)
    3043           6 :                 continue;
    3044             :         }
    3045             : 
    3046         420 :         attname = NameStr(att->attname);
    3047         420 :         attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
    3048             : 
    3049         420 :         if (isnull)
    3050             :         {
    3051             :             /*
    3052             :              * Store (attname => undef) and move on.  Note we can't use
    3053             :              * &PL_sv_undef here; see "AVs, HVs and undefined values" in
    3054             :              * perlguts for an explanation.
    3055             :              */
    3056          14 :             hv_store_string(hv, attname, newSV(0));
    3057          14 :             continue;
    3058             :         }
    3059             : 
    3060         406 :         if (type_is_rowtype(att->atttypid))
    3061             :         {
    3062          84 :             SV         *sv = plperl_hash_from_datum(attr);
    3063             : 
    3064          84 :             hv_store_string(hv, attname, sv);
    3065             :         }
    3066             :         else
    3067             :         {
    3068             :             SV         *sv;
    3069             :             Oid         funcid;
    3070             : 
    3071         322 :             if (OidIsValid(get_base_element_type(att->atttypid)))
    3072           8 :                 sv = plperl_ref_from_pg_array(attr, att->atttypid);
    3073         314 :             else if ((funcid = get_transform_fromsql(att->atttypid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
    3074          14 :                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr));
    3075             :             else
    3076             :             {
    3077             :                 char       *outputstr;
    3078             : 
    3079             :                 /* XXX should have a way to cache these lookups */
    3080         300 :                 getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
    3081             : 
    3082         300 :                 outputstr = OidOutputFunctionCall(typoutput, attr);
    3083         300 :                 sv = cstr2sv(outputstr);
    3084         300 :                 pfree(outputstr);
    3085             :             }
    3086             : 
    3087         322 :             hv_store_string(hv, attname, sv);
    3088             :         }
    3089             :     }
    3090         260 :     return newRV_noinc((SV *) hv);
    3091             : }
    3092             : 
    3093             : 
    3094             : static void
    3095         648 : check_spi_usage_allowed(void)
    3096             : {
    3097             :     /* see comment in plperl_fini() */
    3098         648 :     if (plperl_ending)
    3099             :     {
    3100             :         /* simple croak as we don't want to involve PostgreSQL code */
    3101           0 :         croak("SPI functions can not be used in END blocks");
    3102             :     }
    3103             : 
    3104             :     /*
    3105             :      * Disallow SPI usage if we're not executing a fully-compiled plperl
    3106             :      * function.  It might seem impossible to get here in that case, but there
    3107             :      * are cases where Perl will try to execute code during compilation.  If
    3108             :      * we proceed we are likely to crash trying to dereference the prodesc
    3109             :      * pointer.  Working around that might be possible, but it seems unwise
    3110             :      * because it'd allow code execution to happen while validating a
    3111             :      * function, which is undesirable.
    3112             :      */
    3113         648 :     if (current_call_data == NULL || current_call_data->prodesc == NULL)
    3114             :     {
    3115             :         /* simple croak as we don't want to involve PostgreSQL code */
    3116           0 :         croak("SPI functions can not be used during function compilation");
    3117             :     }
    3118         648 : }
    3119             : 
    3120             : 
    3121             : HV *
    3122         112 : plperl_spi_exec(char *query, int limit)
    3123             : {
    3124             :     HV         *ret_hv;
    3125             : 
    3126             :     /*
    3127             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3128             :      * sanely
    3129             :      */
    3130         112 :     MemoryContext oldcontext = CurrentMemoryContext;
    3131         112 :     ResourceOwner oldowner = CurrentResourceOwner;
    3132             : 
    3133         112 :     check_spi_usage_allowed();
    3134             : 
    3135         112 :     BeginInternalSubTransaction(NULL);
    3136             :     /* Want to run inside function's memory context */
    3137         112 :     MemoryContextSwitchTo(oldcontext);
    3138             : 
    3139         112 :     PG_TRY();
    3140             :     {
    3141             :         int         spi_rv;
    3142             : 
    3143         112 :         pg_verifymbstr(query, strlen(query), false);
    3144             : 
    3145         112 :         spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
    3146             :                              limit);
    3147         100 :         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
    3148             :                                                  spi_rv);
    3149             : 
    3150             :         /* Commit the inner transaction, return to outer xact context */
    3151         100 :         ReleaseCurrentSubTransaction();
    3152         100 :         MemoryContextSwitchTo(oldcontext);
    3153         100 :         CurrentResourceOwner = oldowner;
    3154             :     }
    3155          12 :     PG_CATCH();
    3156             :     {
    3157             :         ErrorData  *edata;
    3158             : 
    3159             :         /* Save error info */
    3160          12 :         MemoryContextSwitchTo(oldcontext);
    3161          12 :         edata = CopyErrorData();
    3162          12 :         FlushErrorState();
    3163             : 
    3164             :         /* Abort the inner transaction */
    3165          12 :         RollbackAndReleaseCurrentSubTransaction();
    3166          12 :         MemoryContextSwitchTo(oldcontext);
    3167          12 :         CurrentResourceOwner = oldowner;
    3168             : 
    3169             :         /* Punt the error to Perl */
    3170          12 :         croak_cstr(edata->message);
    3171             : 
    3172             :         /* Can't get here, but keep compiler quiet */
    3173           0 :         return NULL;
    3174             :     }
    3175         100 :     PG_END_TRY();
    3176             : 
    3177         100 :     return ret_hv;
    3178             : }
    3179             : 
    3180             : 
    3181             : static HV  *
    3182         112 : plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed,
    3183             :                                 int status)
    3184             : {
    3185         112 :     dTHX;
    3186             :     HV         *result;
    3187             : 
    3188         112 :     check_spi_usage_allowed();
    3189             : 
    3190         112 :     result = newHV();
    3191             : 
    3192         112 :     hv_store_string(result, "status",
    3193             :                     cstr2sv(SPI_result_code_string(status)));
    3194         112 :     hv_store_string(result, "processed",
    3195             :                     (processed > (uint64) UV_MAX) ?
    3196             :                     newSVnv((NV) processed) :
    3197             :                     newSVuv((UV) processed));
    3198             : 
    3199         112 :     if (status > 0 && tuptable)
    3200             :     {
    3201             :         AV         *rows;
    3202             :         SV         *row;
    3203             :         uint64      i;
    3204             : 
    3205             :         /* Prevent overflow in call to av_extend() */
    3206          20 :         if (processed > (uint64) AV_SIZE_MAX)
    3207           0 :             ereport(ERROR,
    3208             :                     (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
    3209             :                      errmsg("query result has too many rows to fit in a Perl array")));
    3210             : 
    3211          20 :         rows = newAV();
    3212          20 :         av_extend(rows, processed);
    3213          40 :         for (i = 0; i < processed; i++)
    3214             :         {
    3215          20 :             row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc, true);
    3216          20 :             av_push(rows, row);
    3217             :         }
    3218          20 :         hv_store_string(result, "rows",
    3219             :                         newRV_noinc((SV *) rows));
    3220             :     }
    3221             : 
    3222         112 :     SPI_freetuptable(tuptable);
    3223             : 
    3224         112 :     return result;
    3225             : }
    3226             : 
    3227             : 
    3228             : /*
    3229             :  * plperl_return_next catches any error and converts it to a Perl error.
    3230             :  * We assume (perhaps without adequate justification) that we need not abort
    3231             :  * the current transaction if the Perl code traps the error.
    3232             :  */
    3233             : void
    3234         174 : plperl_return_next(SV *sv)
    3235             : {
    3236         174 :     MemoryContext oldcontext = CurrentMemoryContext;
    3237             : 
    3238         174 :     check_spi_usage_allowed();
    3239             : 
    3240         174 :     PG_TRY();
    3241             :     {
    3242         174 :         plperl_return_next_internal(sv);
    3243             :     }
    3244           0 :     PG_CATCH();
    3245             :     {
    3246             :         ErrorData  *edata;
    3247             : 
    3248             :         /* Must reset elog.c's state */
    3249           0 :         MemoryContextSwitchTo(oldcontext);
    3250           0 :         edata = CopyErrorData();
    3251           0 :         FlushErrorState();
    3252             : 
    3253             :         /* Punt the error to Perl */
    3254           0 :         croak_cstr(edata->message);
    3255             :     }
    3256         174 :     PG_END_TRY();
    3257         174 : }
    3258             : 
    3259             : /*
    3260             :  * plperl_return_next_internal reports any errors in Postgres fashion
    3261             :  * (via ereport).
    3262             :  */
    3263             : static void
    3264         282 : plperl_return_next_internal(SV *sv)
    3265             : {
    3266             :     plperl_proc_desc *prodesc;
    3267             :     FunctionCallInfo fcinfo;
    3268             :     ReturnSetInfo *rsi;
    3269             :     MemoryContext old_cxt;
    3270             : 
    3271         282 :     if (!sv)
    3272           0 :         return;
    3273             : 
    3274         282 :     prodesc = current_call_data->prodesc;
    3275         282 :     fcinfo = current_call_data->fcinfo;
    3276         282 :     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
    3277             : 
    3278         282 :     if (!prodesc->fn_retisset)
    3279           0 :         ereport(ERROR,
    3280             :                 (errcode(ERRCODE_SYNTAX_ERROR),
    3281             :                  errmsg("cannot use return_next in a non-SETOF function")));
    3282             : 
    3283         282 :     if (!current_call_data->ret_tdesc)
    3284             :     {
    3285             :         TupleDesc   tupdesc;
    3286             : 
    3287             :         Assert(!current_call_data->tuple_store);
    3288             : 
    3289             :         /*
    3290             :          * This is the first call to return_next in the current PL/Perl
    3291             :          * function call, so identify the output tuple type and create a
    3292             :          * tuplestore to hold the result rows.
    3293             :          */
    3294          68 :         if (prodesc->fn_retistuple)
    3295             :         {
    3296             :             TypeFuncClass funcclass;
    3297             :             Oid         typid;
    3298             : 
    3299          34 :             funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
    3300          34 :             if (funcclass != TYPEFUNC_COMPOSITE &&
    3301             :                 funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
    3302           4 :                 ereport(ERROR,
    3303             :                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
    3304             :                          errmsg("function returning record called in context "
    3305             :                                 "that cannot accept type record")));
    3306             :             /* if domain-over-composite, remember the domain's type OID */
    3307          30 :             if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
    3308           4 :                 current_call_data->cdomain_oid = typid;
    3309             :         }
    3310             :         else
    3311             :         {
    3312          34 :             tupdesc = rsi->expectedDesc;
    3313             :             /* Protect assumption below that we return exactly one column */
    3314          34 :             if (tupdesc == NULL || tupdesc->natts != 1)
    3315           0 :                 elog(ERROR, "expected single-column result descriptor for non-composite SETOF result");
    3316             :         }
    3317             : 
    3318             :         /*
    3319             :          * Make sure the tuple_store and ret_tdesc are sufficiently
    3320             :          * long-lived.
    3321             :          */
    3322          64 :         old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
    3323             : 
    3324          64 :         current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
    3325         128 :         current_call_data->tuple_store =
    3326          64 :             tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
    3327             :                                   false, work_mem);
    3328             : 
    3329          64 :         MemoryContextSwitchTo(old_cxt);
    3330             :     }
    3331             : 
    3332             :     /*
    3333             :      * Producing the tuple we want to return requires making plenty of
    3334             :      * palloc() allocations that are not cleaned up. Since this function can
    3335             :      * be called many times before the current memory context is reset, we
    3336             :      * need to do those allocations in a temporary context.
    3337             :      */
    3338         278 :     if (!current_call_data->tmp_cxt)
    3339             :     {
    3340          64 :         current_call_data->tmp_cxt =
    3341          64 :             AllocSetContextCreate(CurrentMemoryContext,
    3342             :                                   "PL/Perl return_next temporary cxt",
    3343             :                                   ALLOCSET_DEFAULT_SIZES);
    3344             :     }
    3345             : 
    3346         278 :     old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
    3347             : 
    3348         278 :     if (prodesc->fn_retistuple)
    3349             :     {
    3350             :         HeapTuple   tuple;
    3351             : 
    3352          86 :         if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
    3353           8 :             ereport(ERROR,
    3354             :                     (errcode(ERRCODE_DATATYPE_MISMATCH),
    3355             :                      errmsg("SETOF-composite-returning PL/Perl function "
    3356             :                             "must call return_next with reference to hash")));
    3357             : 
    3358          78 :         tuple = plperl_build_tuple_result((HV *) SvRV(sv),
    3359          78 :                                           current_call_data->ret_tdesc);
    3360             : 
    3361          76 :         if (OidIsValid(current_call_data->cdomain_oid))
    3362           8 :             domain_check(HeapTupleGetDatum(tuple), false,
    3363           8 :                          current_call_data->cdomain_oid,
    3364           8 :                          &current_call_data->cdomain_info,
    3365           8 :                          rsi->econtext->ecxt_per_query_memory);
    3366             : 
    3367          74 :         tuplestore_puttuple(current_call_data->tuple_store, tuple);
    3368             :     }
    3369         192 :     else if (prodesc->result_oid)
    3370             :     {
    3371             :         Datum       ret[1];
    3372             :         bool        isNull[1];
    3373             : 
    3374         192 :         ret[0] = plperl_sv_to_datum(sv,
    3375             :                                     prodesc->result_oid,
    3376             :                                     -1,
    3377             :                                     fcinfo,
    3378             :                                     &prodesc->result_in_func,
    3379             :                                     prodesc->result_typioparam,
    3380             :                                     &isNull[0]);
    3381             : 
    3382         192 :         tuplestore_putvalues(current_call_data->tuple_store,
    3383         192 :                              current_call_data->ret_tdesc,
    3384             :                              ret, isNull);
    3385             :     }
    3386             : 
    3387         266 :     MemoryContextSwitchTo(old_cxt);
    3388         266 :     MemoryContextReset(current_call_data->tmp_cxt);
    3389             : }
    3390             : 
    3391             : 
    3392             : SV *
    3393          18 : plperl_spi_query(char *query)
    3394             : {
    3395             :     SV         *cursor;
    3396             : 
    3397             :     /*
    3398             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3399             :      * sanely
    3400             :      */
    3401          18 :     MemoryContext oldcontext = CurrentMemoryContext;
    3402          18 :     ResourceOwner oldowner = CurrentResourceOwner;
    3403             : 
    3404          18 :     check_spi_usage_allowed();
    3405             : 
    3406          18 :     BeginInternalSubTransaction(NULL);
    3407             :     /* Want to run inside function's memory context */
    3408          18 :     MemoryContextSwitchTo(oldcontext);
    3409             : 
    3410          18 :     PG_TRY();
    3411             :     {
    3412             :         SPIPlanPtr  plan;
    3413             :         Portal      portal;
    3414             : 
    3415             :         /* Make sure the query is validly encoded */
    3416          18 :         pg_verifymbstr(query, strlen(query), false);
    3417             : 
    3418             :         /* Create a cursor for the query */
    3419          18 :         plan = SPI_prepare(query, 0, NULL);
    3420          18 :         if (plan == NULL)
    3421           0 :             elog(ERROR, "SPI_prepare() failed:%s",
    3422             :                  SPI_result_code_string(SPI_result));
    3423             : 
    3424          18 :         portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
    3425          18 :         SPI_freeplan(plan);
    3426          18 :         if (portal == NULL)
    3427           0 :             elog(ERROR, "SPI_cursor_open() failed:%s",
    3428             :                  SPI_result_code_string(SPI_result));
    3429          18 :         cursor = cstr2sv(portal->name);
    3430             : 
    3431          18 :         PinPortal(portal);
    3432             : 
    3433             :         /* Commit the inner transaction, return to outer xact context */
    3434          18 :         ReleaseCurrentSubTransaction();
    3435          18 :         MemoryContextSwitchTo(oldcontext);
    3436          18 :         CurrentResourceOwner = oldowner;
    3437             :     }
    3438           0 :     PG_CATCH();
    3439             :     {
    3440             :         ErrorData  *edata;
    3441             : 
    3442             :         /* Save error info */
    3443           0 :         MemoryContextSwitchTo(oldcontext);
    3444           0 :         edata = CopyErrorData();
    3445           0 :         FlushErrorState();
    3446             : 
    3447             :         /* Abort the inner transaction */
    3448           0 :         RollbackAndReleaseCurrentSubTransaction();
    3449           0 :         MemoryContextSwitchTo(oldcontext);
    3450           0 :         CurrentResourceOwner = oldowner;
    3451             : 
    3452             :         /* Punt the error to Perl */
    3453           0 :         croak_cstr(edata->message);
    3454             : 
    3455             :         /* Can't get here, but keep compiler quiet */
    3456           0 :         return NULL;
    3457             :     }
    3458          18 :     PG_END_TRY();
    3459             : 
    3460          18 :     return cursor;
    3461             : }
    3462             : 
    3463             : 
    3464             : SV *
    3465          72 : plperl_spi_fetchrow(char *cursor)
    3466             : {
    3467             :     SV         *row;
    3468             : 
    3469             :     /*
    3470             :      * Execute the FETCH inside a sub-transaction, so we can cope with errors
    3471             :      * sanely
    3472             :      */
    3473          72 :     MemoryContext oldcontext = CurrentMemoryContext;
    3474          72 :     ResourceOwner oldowner = CurrentResourceOwner;
    3475             : 
    3476          72 :     check_spi_usage_allowed();
    3477             : 
    3478          72 :     BeginInternalSubTransaction(NULL);
    3479             :     /* Want to run inside function's memory context */
    3480          72 :     MemoryContextSwitchTo(oldcontext);
    3481             : 
    3482          72 :     PG_TRY();
    3483             :     {
    3484          72 :         dTHX;
    3485          72 :         Portal      p = SPI_cursor_find(cursor);
    3486             : 
    3487          72 :         if (!p)
    3488             :         {
    3489           0 :             row = &PL_sv_undef;
    3490             :         }
    3491             :         else
    3492             :         {
    3493          72 :             SPI_cursor_fetch(p, true, 1);
    3494          72 :             if (SPI_processed == 0)
    3495             :             {
    3496          18 :                 UnpinPortal(p);
    3497          18 :                 SPI_cursor_close(p);
    3498          18 :                 row = &PL_sv_undef;
    3499             :             }
    3500             :             else
    3501             :             {
    3502          54 :                 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
    3503          54 :                                              SPI_tuptable->tupdesc,
    3504             :                                              true);
    3505             :             }
    3506          72 :             SPI_freetuptable(SPI_tuptable);
    3507             :         }
    3508             : 
    3509             :         /* Commit the inner transaction, return to outer xact context */
    3510          72 :         ReleaseCurrentSubTransaction();
    3511          72 :         MemoryContextSwitchTo(oldcontext);
    3512          72 :         CurrentResourceOwner = oldowner;
    3513             :     }
    3514           0 :     PG_CATCH();
    3515             :     {
    3516             :         ErrorData  *edata;
    3517             : 
    3518             :         /* Save error info */
    3519           0 :         MemoryContextSwitchTo(oldcontext);
    3520           0 :         edata = CopyErrorData();
    3521           0 :         FlushErrorState();
    3522             : 
    3523             :         /* Abort the inner transaction */
    3524           0 :         RollbackAndReleaseCurrentSubTransaction();
    3525           0 :         MemoryContextSwitchTo(oldcontext);
    3526           0 :         CurrentResourceOwner = oldowner;
    3527             : 
    3528             :         /* Punt the error to Perl */
    3529           0 :         croak_cstr(edata->message);
    3530             : 
    3531             :         /* Can't get here, but keep compiler quiet */
    3532           0 :         return NULL;
    3533             :     }
    3534          72 :     PG_END_TRY();
    3535             : 
    3536          72 :     return row;
    3537             : }
    3538             : 
    3539             : void
    3540           2 : plperl_spi_cursor_close(char *cursor)
    3541             : {
    3542             :     Portal      p;
    3543             : 
    3544           2 :     check_spi_usage_allowed();
    3545             : 
    3546           2 :     p = SPI_cursor_find(cursor);
    3547             : 
    3548           2 :     if (p)
    3549             :     {
    3550           2 :         UnpinPortal(p);
    3551           2 :         SPI_cursor_close(p);
    3552             :     }
    3553           2 : }
    3554             : 
    3555             : SV *
    3556          16 : plperl_spi_prepare(char *query, int argc, SV **argv)
    3557             : {
    3558          16 :     volatile SPIPlanPtr plan = NULL;
    3559          16 :     volatile MemoryContext plan_cxt = NULL;
    3560          16 :     plperl_query_desc *volatile qdesc = NULL;
    3561          16 :     plperl_query_entry *volatile hash_entry = NULL;
    3562          16 :     MemoryContext oldcontext = CurrentMemoryContext;
    3563          16 :     ResourceOwner oldowner = CurrentResourceOwner;
    3564             :     MemoryContext work_cxt;
    3565             :     bool        found;
    3566             :     int         i;
    3567             : 
    3568          16 :     check_spi_usage_allowed();
    3569             : 
    3570          16 :     BeginInternalSubTransaction(NULL);
    3571          16 :     MemoryContextSwitchTo(oldcontext);
    3572             : 
    3573          16 :     PG_TRY();
    3574             :     {
    3575          16 :         CHECK_FOR_INTERRUPTS();
    3576             : 
    3577             :         /************************************************************
    3578             :          * Allocate the new querydesc structure
    3579             :          *
    3580             :          * The qdesc struct, as well as all its subsidiary data, lives in its
    3581             :          * plan_cxt.  But note that the SPIPlan does not.
    3582             :          ************************************************************/
    3583          16 :         plan_cxt = AllocSetContextCreate(TopMemoryContext,
    3584             :                                          "PL/Perl spi_prepare query",
    3585             :                                          ALLOCSET_SMALL_SIZES);
    3586          16 :         MemoryContextSwitchTo(plan_cxt);
    3587          16 :         qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc));
    3588          16 :         snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
    3589          16 :         qdesc->plan_cxt = plan_cxt;
    3590          16 :         qdesc->nargs = argc;
    3591          16 :         qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid));
    3592          16 :         qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo));
    3593          16 :         qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid));
    3594          16 :         MemoryContextSwitchTo(oldcontext);
    3595             : 
    3596             :         /************************************************************
    3597             :          * Do the following work in a short-lived context so that we don't
    3598             :          * leak a lot of memory in the PL/Perl function's SPI Proc context.
    3599             :          ************************************************************/
    3600          16 :         work_cxt = AllocSetContextCreate(CurrentMemoryContext,
    3601             :                                          "PL/Perl spi_prepare workspace",
    3602             :                                          ALLOCSET_DEFAULT_SIZES);
    3603          16 :         MemoryContextSwitchTo(work_cxt);
    3604             : 
    3605             :         /************************************************************
    3606             :          * Resolve argument type names and then look them up by oid
    3607             :          * in the system cache, and remember the required information
    3608             :          * for input conversion.
    3609             :          ************************************************************/
    3610          30 :         for (i = 0; i < argc; i++)
    3611             :         {
    3612             :             Oid         typId,
    3613             :                         typInput,
    3614             :                         typIOParam;
    3615             :             int32       typmod;
    3616             :             char       *typstr;
    3617             : 
    3618          16 :             typstr = sv2cstr(argv[i]);
    3619          16 :             parseTypeString(typstr, &typId, &typmod, false);
    3620          14 :             pfree(typstr);
    3621             : 
    3622          14 :             getTypeInputInfo(typId, &typInput, &typIOParam);
    3623             : 
    3624          14 :             qdesc->argtypes[i] = typId;
    3625          14 :             fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
    3626          14 :             qdesc->argtypioparams[i] = typIOParam;
    3627             :         }
    3628             : 
    3629             :         /* Make sure the query is validly encoded */
    3630          14 :         pg_verifymbstr(query, strlen(query), false);
    3631             : 
    3632             :         /************************************************************
    3633             :          * Prepare the plan and check for errors
    3634             :          ************************************************************/
    3635          14 :         plan = SPI_prepare(query, argc, qdesc->argtypes);
    3636             : 
    3637          14 :         if (plan == NULL)
    3638           0 :             elog(ERROR, "SPI_prepare() failed:%s",
    3639             :                  SPI_result_code_string(SPI_result));
    3640             : 
    3641             :         /************************************************************
    3642             :          * Save the plan into permanent memory (right now it's in the
    3643             :          * SPI procCxt, which will go away at function end).
    3644             :          ************************************************************/
    3645          14 :         if (SPI_keepplan(plan))
    3646           0 :             elog(ERROR, "SPI_keepplan() failed");
    3647          14 :         qdesc->plan = plan;
    3648             : 
    3649             :         /************************************************************
    3650             :          * Insert a hashtable entry for the plan.
    3651             :          ************************************************************/
    3652          28 :         hash_entry = hash_search(plperl_active_interp->query_hash,
    3653          14 :                                  qdesc->qname,
    3654             :                                  HASH_ENTER, &found);
    3655          14 :         hash_entry->query_data = qdesc;
    3656             : 
    3657             :         /* Get rid of workspace */
    3658          14 :         MemoryContextDelete(work_cxt);
    3659             : 
    3660             :         /* Commit the inner transaction, return to outer xact context */
    3661          14 :         ReleaseCurrentSubTransaction();
    3662          14 :         MemoryContextSwitchTo(oldcontext);
    3663          14 :         CurrentResourceOwner = oldowner;
    3664             :     }
    3665           2 :     PG_CATCH();
    3666             :     {
    3667             :         ErrorData  *edata;
    3668             : 
    3669             :         /* Save error info */
    3670           2 :         MemoryContextSwitchTo(oldcontext);
    3671           2 :         edata = CopyErrorData();
    3672           2 :         FlushErrorState();
    3673             : 
    3674             :         /* Drop anything we managed to allocate */
    3675           2 :         if (hash_entry)
    3676           0 :             hash_search(plperl_active_interp->query_hash,
    3677           0 :                         qdesc->qname,
    3678             :                         HASH_REMOVE, NULL);
    3679           2 :         if (plan_cxt)
    3680           2 :             MemoryContextDelete(plan_cxt);
    3681           2 :         if (plan)
    3682           0 :             SPI_freeplan(plan);
    3683             : 
    3684             :         /* Abort the inner transaction */
    3685           2 :         RollbackAndReleaseCurrentSubTransaction();
    3686           2 :         MemoryContextSwitchTo(oldcontext);
    3687           2 :         CurrentResourceOwner = oldowner;
    3688             : 
    3689             :         /* Punt the error to Perl */
    3690           2 :         croak_cstr(edata->message);
    3691             : 
    3692             :         /* Can't get here, but keep compiler quiet */
    3693           0 :         return NULL;
    3694             :     }
    3695          14 :     PG_END_TRY();
    3696             : 
    3697             :     /************************************************************
    3698             :      * Return the query's hash key to the caller.
    3699             :      ************************************************************/
    3700          14 :     return cstr2sv(qdesc->qname);
    3701             : }
    3702             : 
    3703             : HV *
    3704          12 : plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
    3705             : {
    3706             :     HV         *ret_hv;
    3707             :     SV        **sv;
    3708             :     int         i,
    3709             :                 limit,
    3710             :                 spi_rv;
    3711             :     char       *nulls;
    3712             :     Datum      *argvalues;
    3713             :     plperl_query_desc *qdesc;
    3714             :     plperl_query_entry *hash_entry;
    3715             : 
    3716             :     /*
    3717             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3718             :      * sanely
    3719             :      */
    3720          12 :     MemoryContext oldcontext = CurrentMemoryContext;
    3721          12 :     ResourceOwner oldowner = CurrentResourceOwner;
    3722             : 
    3723          12 :     check_spi_usage_allowed();
    3724             : 
    3725          12 :     BeginInternalSubTransaction(NULL);
    3726             :     /* Want to run inside function's memory context */
    3727          12 :     MemoryContextSwitchTo(oldcontext);
    3728             : 
    3729          12 :     PG_TRY();
    3730             :     {
    3731          12 :         dTHX;
    3732             : 
    3733             :         /************************************************************
    3734             :          * Fetch the saved plan descriptor, see if it's o.k.
    3735             :          ************************************************************/
    3736          12 :         hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3737             :                                  HASH_FIND, NULL);
    3738          12 :         if (hash_entry == NULL)
    3739           0 :             elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
    3740             : 
    3741          12 :         qdesc = hash_entry->query_data;
    3742          12 :         if (qdesc == NULL)
    3743           0 :             elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished");
    3744             : 
    3745          12 :         if (qdesc->nargs != argc)
    3746           0 :             elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
    3747             :                  qdesc->nargs, argc);
    3748             : 
    3749             :         /************************************************************
    3750             :          * Parse eventual attributes
    3751             :          ************************************************************/
    3752          12 :         limit = 0;
    3753          12 :         if (attr != NULL)
    3754             :         {
    3755           4 :             sv = hv_fetch_string(attr, "limit");
    3756           4 :             if (sv && *sv && SvIOK(*sv))
    3757           0 :                 limit = SvIV(*sv);
    3758             :         }
    3759             :         /************************************************************
    3760             :          * Set up arguments
    3761             :          ************************************************************/
    3762          12 :         if (argc > 0)
    3763             :         {
    3764           8 :             nulls = (char *) palloc(argc);
    3765           8 :             argvalues = (Datum *) palloc(argc * sizeof(Datum));
    3766             :         }
    3767             :         else
    3768             :         {
    3769           4 :             nulls = NULL;
    3770           4 :             argvalues = NULL;
    3771             :         }
    3772             : 
    3773          20 :         for (i = 0; i < argc; i++)
    3774             :         {
    3775             :             bool        isnull;
    3776             : 
    3777          16 :             argvalues[i] = plperl_sv_to_datum(argv[i],
    3778           8 :                                               qdesc->argtypes[i],
    3779             :                                               -1,
    3780             :                                               NULL,
    3781           8 :                                               &qdesc->arginfuncs[i],
    3782           8 :                                               qdesc->argtypioparams[i],
    3783             :                                               &isnull);
    3784           8 :             nulls[i] = isnull ? 'n' : ' ';
    3785             :         }
    3786             : 
    3787             :         /************************************************************
    3788             :          * go
    3789             :          ************************************************************/
    3790          24 :         spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
    3791          12 :                                   current_call_data->prodesc->fn_readonly, limit);
    3792          12 :         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
    3793             :                                                  spi_rv);
    3794          12 :         if (argc > 0)
    3795             :         {
    3796           8 :             pfree(argvalues);
    3797           8 :             pfree(nulls);
    3798             :         }
    3799             : 
    3800             :         /* Commit the inner transaction, return to outer xact context */
    3801          12 :         ReleaseCurrentSubTransaction();
    3802          12 :         MemoryContextSwitchTo(oldcontext);
    3803          12 :         CurrentResourceOwner = oldowner;
    3804             :     }
    3805           0 :     PG_CATCH();
    3806             :     {
    3807             :         ErrorData  *edata;
    3808             : 
    3809             :         /* Save error info */
    3810           0 :         MemoryContextSwitchTo(oldcontext);
    3811           0 :         edata = CopyErrorData();
    3812           0 :         FlushErrorState();
    3813             : 
    3814             :         /* Abort the inner transaction */
    3815           0 :         RollbackAndReleaseCurrentSubTransaction();
    3816           0 :         MemoryContextSwitchTo(oldcontext);
    3817           0 :         CurrentResourceOwner = oldowner;
    3818             : 
    3819             :         /* Punt the error to Perl */
    3820           0 :         croak_cstr(edata->message);
    3821             : 
    3822             :         /* Can't get here, but keep compiler quiet */
    3823           0 :         return NULL;
    3824             :     }
    3825          12 :     PG_END_TRY();
    3826             : 
    3827          12 :     return ret_hv;
    3828             : }
    3829             : 
    3830             : SV *
    3831           4 : plperl_spi_query_prepared(char *query, int argc, SV **argv)
    3832             : {
    3833             :     int         i;
    3834             :     char       *nulls;
    3835             :     Datum      *argvalues;
    3836             :     plperl_query_desc *qdesc;
    3837             :     plperl_query_entry *hash_entry;
    3838             :     SV         *cursor;
    3839           4 :     Portal      portal = NULL;
    3840             : 
    3841             :     /*
    3842             :      * Execute the query inside a sub-transaction, so we can cope with errors
    3843             :      * sanely
    3844             :      */
    3845           4 :     MemoryContext oldcontext = CurrentMemoryContext;
    3846           4 :     ResourceOwner oldowner = CurrentResourceOwner;
    3847             : 
    3848           4 :     check_spi_usage_allowed();
    3849             : 
    3850           4 :     BeginInternalSubTransaction(NULL);
    3851             :     /* Want to run inside function's memory context */
    3852           4 :     MemoryContextSwitchTo(oldcontext);
    3853             : 
    3854           4 :     PG_TRY();
    3855             :     {
    3856             :         /************************************************************
    3857             :          * Fetch the saved plan descriptor, see if it's o.k.
    3858             :          ************************************************************/
    3859           4 :         hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3860             :                                  HASH_FIND, NULL);
    3861           4 :         if (hash_entry == NULL)
    3862           0 :             elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
    3863             : 
    3864           4 :         qdesc = hash_entry->query_data;
    3865           4 :         if (qdesc == NULL)
    3866           0 :             elog(ERROR, "spi_query_prepared: plperl query_hash value vanished");
    3867             : 
    3868           4 :         if (qdesc->nargs != argc)
    3869           0 :             elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
    3870             :                  qdesc->nargs, argc);
    3871             : 
    3872             :         /************************************************************
    3873             :          * Set up arguments
    3874             :          ************************************************************/
    3875           4 :         if (argc > 0)
    3876             :         {
    3877           4 :             nulls = (char *) palloc(argc);
    3878           4 :             argvalues = (Datum *) palloc(argc * sizeof(Datum));
    3879             :         }
    3880             :         else
    3881             :         {
    3882           0 :             nulls = NULL;
    3883           0 :             argvalues = NULL;
    3884             :         }
    3885             : 
    3886          10 :         for (i = 0; i < argc; i++)
    3887             :         {
    3888             :             bool        isnull;
    3889             : 
    3890          12 :             argvalues[i] = plperl_sv_to_datum(argv[i],
    3891           6 :                                               qdesc->argtypes[i],
    3892             :                                               -1,
    3893             :                                               NULL,
    3894           6 :                                               &qdesc->arginfuncs[i],
    3895           6 :                                               qdesc->argtypioparams[i],
    3896             :                                               &isnull);
    3897           6 :             nulls[i] = isnull ? 'n' : ' ';
    3898             :         }
    3899             : 
    3900             :         /************************************************************
    3901             :          * go
    3902             :          ************************************************************/
    3903           8 :         portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
    3904           4 :                                  current_call_data->prodesc->fn_readonly);
    3905           4 :         if (argc > 0)
    3906             :         {
    3907           4 :             pfree(argvalues);
    3908           4 :             pfree(nulls);
    3909             :         }
    3910           4 :         if (portal == NULL)
    3911           0 :             elog(ERROR, "SPI_cursor_open() failed:%s",
    3912             :                  SPI_result_code_string(SPI_result));
    3913             : 
    3914           4 :         cursor = cstr2sv(portal->name);
    3915             : 
    3916           4 :         PinPortal(portal);
    3917             : 
    3918             :         /* Commit the inner transaction, return to outer xact context */
    3919           4 :         ReleaseCurrentSubTransaction();
    3920           4 :         MemoryContextSwitchTo(oldcontext);
    3921           4 :         CurrentResourceOwner = oldowner;
    3922             :     }
    3923           0 :     PG_CATCH();
    3924             :     {
    3925             :         ErrorData  *edata;
    3926             : 
    3927             :         /* Save error info */
    3928           0 :         MemoryContextSwitchTo(oldcontext);
    3929           0 :         edata = CopyErrorData();
    3930           0 :         FlushErrorState();
    3931             : 
    3932             :         /* Abort the inner transaction */
    3933           0 :         RollbackAndReleaseCurrentSubTransaction();
    3934           0 :         MemoryContextSwitchTo(oldcontext);
    3935           0 :         CurrentResourceOwner = oldowner;
    3936             : 
    3937             :         /* Punt the error to Perl */
    3938           0 :         croak_cstr(edata->message);
    3939             : 
    3940             :         /* Can't get here, but keep compiler quiet */
    3941           0 :         return NULL;
    3942             :     }
    3943           4 :     PG_END_TRY();
    3944             : 
    3945           4 :     return cursor;
    3946             : }
    3947             : 
    3948             : void
    3949          10 : plperl_spi_freeplan(char *query)
    3950             : {
    3951             :     SPIPlanPtr  plan;
    3952             :     plperl_query_desc *qdesc;
    3953             :     plperl_query_entry *hash_entry;
    3954             : 
    3955          10 :     check_spi_usage_allowed();
    3956             : 
    3957          10 :     hash_entry = hash_search(plperl_active_interp->query_hash, query,
    3958             :                              HASH_FIND, NULL);
    3959          10 :     if (hash_entry == NULL)
    3960           0 :         elog(ERROR, "spi_freeplan: Invalid prepared query passed");
    3961             : 
    3962          10 :     qdesc = hash_entry->query_data;
    3963          10 :     if (qdesc == NULL)
    3964           0 :         elog(ERROR, "spi_freeplan: plperl query_hash value vanished");
    3965          10 :     plan = qdesc->plan;
    3966             : 
    3967             :     /*
    3968             :      * free all memory before SPI_freeplan, so if it dies, nothing will be
    3969             :      * left over
    3970             :      */
    3971          10 :     hash_search(plperl_active_interp->query_hash, query,
    3972             :                 HASH_REMOVE, NULL);
    3973             : 
    3974          10 :     MemoryContextDelete(qdesc->plan_cxt);
    3975             : 
    3976          10 :     SPI_freeplan(plan);
    3977          10 : }
    3978             : 
    3979             : void
    3980          50 : plperl_spi_commit(void)
    3981             : {
    3982          50 :     MemoryContext oldcontext = CurrentMemoryContext;
    3983             : 
    3984          50 :     check_spi_usage_allowed();
    3985             : 
    3986          50 :     PG_TRY();
    3987             :     {
    3988          50 :         SPI_commit();
    3989             :     }
    3990          10 :     PG_CATCH();
    3991             :     {
    3992             :         ErrorData  *edata;
    3993             : 
    3994             :         /* Save error info */
    3995          10 :         MemoryContextSwitchTo(oldcontext);
    3996          10 :         edata = CopyErrorData();
    3997          10 :         FlushErrorState();
    3998             : 
    3999             :         /* Punt the error to Perl */
    4000          10 :         croak_cstr(edata->message);
    4001             :     }
    4002          40 :     PG_END_TRY();
    4003          40 : }
    4004             : 
    4005             : void
    4006          34 : plperl_spi_rollback(void)
    4007             : {
    4008          34 :     MemoryContext oldcontext = CurrentMemoryContext;
    4009             : 
    4010          34 :     check_spi_usage_allowed();
    4011             : 
    4012          34 :     PG_TRY();
    4013             :     {
    4014          34 :         SPI_rollback();
    4015             :     }
    4016           0 :     PG_CATCH();
    4017             :     {
    4018             :         ErrorData  *edata;
    4019             : 
    4020             :         /* Save error info */
    4021           0 :         MemoryContextSwitchTo(oldcontext);
    4022           0 :         edata = CopyErrorData();
    4023           0 :         FlushErrorState();
    4024             : 
    4025             :         /* Punt the error to Perl */
    4026           0 :         croak_cstr(edata->message);
    4027             :     }
    4028          34 :     PG_END_TRY();
    4029          34 : }
    4030             : 
    4031             : /*
    4032             :  * Implementation of plperl's elog() function
    4033             :  *
    4034             :  * If the error level is less than ERROR, we'll just emit the message and
    4035             :  * return.  When it is ERROR, elog() will longjmp, which we catch and
    4036             :  * turn into a Perl croak().  Note we are assuming that elog() can't have
    4037             :  * any internal failures that are so bad as to require a transaction abort.
    4038             :  *
    4039             :  * The main reason this is out-of-line is to avoid conflicts between XSUB.h
    4040             :  * and the PG_TRY macros.
    4041             :  */
    4042             : void
    4043         366 : plperl_util_elog(int level, SV *msg)
    4044             : {
    4045         366 :     MemoryContext oldcontext = CurrentMemoryContext;
    4046         366 :     char       *volatile cmsg = NULL;
    4047             : 
    4048             :     /*
    4049             :      * We intentionally omit check_spi_usage_allowed() here, as this seems
    4050             :      * safe to allow even in the contexts that that function rejects.
    4051             :      */
    4052             : 
    4053         366 :     PG_TRY();
    4054             :     {
    4055         366 :         cmsg = sv2cstr(msg);
    4056         366 :         elog(level, "%s", cmsg);
    4057         364 :         pfree(cmsg);
    4058             :     }
    4059           2 :     PG_CATCH();
    4060             :     {
    4061             :         ErrorData  *edata;
    4062             : 
    4063             :         /* Must reset elog.c's state */
    4064           2 :         MemoryContextSwitchTo(oldcontext);
    4065           2 :         edata = CopyErrorData();
    4066           2 :         FlushErrorState();
    4067             : 
    4068           2 :         if (cmsg)
    4069           2 :             pfree(cmsg);
    4070             : 
    4071             :         /* Punt the error to Perl */
    4072           2 :         croak_cstr(edata->message);
    4073             :     }
    4074         364 :     PG_END_TRY();
    4075         364 : }
    4076             : 
    4077             : /*
    4078             :  * Store an SV into 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        1342 : hv_store_string(HV *hv, const char *key, SV *val)
    4083             : {
    4084        1342 :     dTHX;
    4085             :     int32       hlen;
    4086             :     char       *hkey;
    4087             :     SV        **ret;
    4088             : 
    4089        1342 :     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
    4090             : 
    4091             :     /*
    4092             :      * hv_store() recognizes a negative klen parameter as meaning a UTF-8
    4093             :      * encoded key.
    4094             :      */
    4095        1342 :     hlen = -(int) strlen(hkey);
    4096        1342 :     ret = hv_store(hv, hkey, hlen, val, 0);
    4097             : 
    4098        1342 :     if (hkey != key)
    4099           0 :         pfree(hkey);
    4100             : 
    4101        1342 :     return ret;
    4102             : }
    4103             : 
    4104             : /*
    4105             :  * Fetch an SV from a hash table under a key that is a string assumed to be
    4106             :  * in the current database's encoding.
    4107             :  */
    4108             : static SV **
    4109          18 : hv_fetch_string(HV *hv, const char *key)
    4110             : {
    4111          18 :     dTHX;
    4112             :     int32       hlen;
    4113             :     char       *hkey;
    4114             :     SV        **ret;
    4115             : 
    4116          18 :     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
    4117             : 
    4118             :     /* See notes in hv_store_string */
    4119          18 :     hlen = -(int) strlen(hkey);
    4120          18 :     ret = hv_fetch(hv, hkey, hlen, 0);
    4121             : 
    4122          18 :     if (hkey != key)
    4123           0 :         pfree(hkey);
    4124             : 
    4125          18 :     return ret;
    4126             : }
    4127             : 
    4128             : /*
    4129             :  * Provide function name for PL/Perl execution errors
    4130             :  */
    4131             : static void
    4132         460 : plperl_exec_callback(void *arg)
    4133             : {
    4134         460 :     char       *procname = (char *) arg;
    4135             : 
    4136         460 :     if (procname)
    4137         460 :         errcontext("PL/Perl function \"%s\"", procname);
    4138         460 : }
    4139             : 
    4140             : /*
    4141             :  * Provide function name for PL/Perl compilation errors
    4142             :  */
    4143             : static void
    4144           8 : plperl_compile_callback(void *arg)
    4145             : {
    4146           8 :     char       *procname = (char *) arg;
    4147             : 
    4148           8 :     if (procname)
    4149           8 :         errcontext("compilation of PL/Perl function \"%s\"", procname);
    4150           8 : }
    4151             : 
    4152             : /*
    4153             :  * Provide error context for the inline handler
    4154             :  */
    4155             : static void
    4156          40 : plperl_inline_callback(void *arg)
    4157             : {
    4158          40 :     errcontext("PL/Perl anonymous code block");
    4159          40 : }
    4160             : 
    4161             : 
    4162             : /*
    4163             :  * Perl's own setlocale(), copied from POSIX.xs
    4164             :  * (needed because of the calls to new_*())
    4165             :  *
    4166             :  * Starting in 5.28, perl exposes Perl_setlocale to do so.
    4167             :  */
    4168             : #if defined(WIN32) && PERL_VERSION_LT(5, 28, 0)
    4169             : static char *
    4170             : setlocale_perl(int category, char *locale)
    4171             : {
    4172             :     dTHX;
    4173             :     char       *RETVAL = setlocale(category, locale);
    4174             : 
    4175             :     if (RETVAL)
    4176             :     {
    4177             : #ifdef USE_LOCALE_CTYPE
    4178             :         if (category == LC_CTYPE
    4179             : #ifdef LC_ALL
    4180             :             || category == LC_ALL
    4181             : #endif
    4182             :             )
    4183             :         {
    4184             :             char       *newctype;
    4185             : 
    4186             : #ifdef LC_ALL
    4187             :             if (category == LC_ALL)
    4188             :                 newctype = setlocale(LC_CTYPE, NULL);
    4189             :             else
    4190             : #endif
    4191             :                 newctype = RETVAL;
    4192             :             new_ctype(newctype);
    4193             :         }
    4194             : #endif                          /* USE_LOCALE_CTYPE */
    4195             : #ifdef USE_LOCALE_COLLATE
    4196             :         if (category == LC_COLLATE
    4197             : #ifdef LC_ALL
    4198             :             || category == LC_ALL
    4199             : #endif
    4200             :             )
    4201             :         {
    4202             :             char       *newcoll;
    4203             : 
    4204             : #ifdef LC_ALL
    4205             :             if (category == LC_ALL)
    4206             :                 newcoll = setlocale(LC_COLLATE, NULL);
    4207             :             else
    4208             : #endif
    4209             :                 newcoll = RETVAL;
    4210             :             new_collate(newcoll);
    4211             :         }
    4212             : #endif                          /* USE_LOCALE_COLLATE */
    4213             : 
    4214             : #ifdef USE_LOCALE_NUMERIC
    4215             :         if (category == LC_NUMERIC
    4216             : #ifdef LC_ALL
    4217             :             || category == LC_ALL
    4218             : #endif
    4219             :             )
    4220             :         {
    4221             :             char       *newnum;
    4222             : 
    4223             : #ifdef LC_ALL
    4224             :             if (category == LC_ALL)
    4225             :                 newnum = setlocale(LC_NUMERIC, NULL);
    4226             :             else
    4227             : #endif
    4228             :                 newnum = RETVAL;
    4229             :             new_numeric(newnum);
    4230             :         }
    4231             : #endif                          /* USE_LOCALE_NUMERIC */
    4232             :     }
    4233             : 
    4234             :     return RETVAL;
    4235             : }
    4236             : #endif                          /* defined(WIN32) && PERL_VERSION_LT(5, 28, 0) */

Generated by: LCOV version 1.14