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

Generated by: LCOV version 1.13