#include "postgres.h"
#include <ctype.h>
#include <fcntl.h>
#include <limits.h>
#include <unistd.h>
#include "access/htup_details.h"
#include "access/xact.h"
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
#include "commands/event_trigger.h"
#include "commands/trigger.h"
#include "executor/spi.h"
#include "funcapi.h"
#include "miscadmin.h"
#include "nodes/makefuncs.h"
#include "parser/parse_type.h"
#include "storage/ipc.h"
#include "tcop/tcopprot.h"
#include "utils/builtins.h"
#include "utils/fmgroids.h"
#include "utils/guc.h"
#include "utils/hsearch.h"
#include "utils/lsyscache.h"
#include "utils/memutils.h"
#include "utils/rel.h"
#include "utils/syscache.h"
#include "utils/typcache.h"
#include "perlchunks.h"
#include "plperl.h"
#include "plperl_opmask.h"

Include dependency graph for plperl.c:

Data Structures
struct	plperl_interp_desc

struct	plperl_proc_desc

struct	plperl_proc_key

struct	plperl_proc_ptr

struct	plperl_call_data

struct	plperl_query_desc

struct	plperl_query_entry

struct	plperl_array_info

Macros
#define	TEXTDOMAIN PG_TEXTDOMAIN("plperl")

#define	increment_prodesc_refcount(prodesc) ((prodesc)->fn_refcount++)

#define	decrement_prodesc_refcount(prodesc)

#define	setlocale_perl(a, b) Perl_setlocale(a,b)

Typedefs
typedef struct plperl_interp_desc	plperl_interp_desc

typedef struct plperl_proc_desc	plperl_proc_desc

typedef struct plperl_proc_key	plperl_proc_key

typedef struct plperl_proc_ptr	plperl_proc_ptr

typedef struct plperl_call_data	plperl_call_data

typedef struct plperl_query_desc	plperl_query_desc

typedef struct plperl_query_entry	plperl_query_entry

typedef struct plperl_array_info	plperl_array_info

Functions
EXTERN_C void	boot_DynaLoader (pTHX_ CV *cv)

EXTERN_C void	boot_PostgreSQL__InServer__Util (pTHX_ CV *cv)

EXTERN_C void	boot_PostgreSQL__InServer__SPI (pTHX_ CV *cv)

static PerlInterpreter *	plperl_init_interp (void)

static void	plperl_destroy_interp (PerlInterpreter **)

static void	plperl_fini (int code, Datum arg)

static void	set_interp_require (bool trusted)

static Datum	plperl_func_handler (PG_FUNCTION_ARGS)

static Datum	plperl_trigger_handler (PG_FUNCTION_ARGS)

static void	plperl_event_trigger_handler (PG_FUNCTION_ARGS)

static void	free_plperl_function (plperl_proc_desc *prodesc)

static plperl_proc_desc *	compile_plperl_function (Oid fn_oid, bool is_trigger, bool is_event_trigger)

static SV *	plperl_hash_from_tuple (HeapTuple tuple, TupleDesc tupdesc, bool include_generated)

static SV *	plperl_hash_from_datum (Datum attr)

static void	check_spi_usage_allowed (void)

static SV *	plperl_ref_from_pg_array (Datum arg, Oid typid)

static SV *	split_array (plperl_array_info *info, int first, int last, int nest)

static SV *	make_array_ref (plperl_array_info *info, int first, int last)

static SV *	get_perl_array_ref (SV *sv)

static Datum	plperl_sv_to_datum (SV sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo finfo, Oid typioparam, bool *isnull)

static void	_sv_to_datum_finfo (Oid typid, FmgrInfo finfo, Oid typioparam)

static Datum	plperl_array_to_datum (SV *src, Oid typid, int32 typmod)

static void	array_to_datum_internal (AV av, ArrayBuildState astatep, int ndims, int dims, int cur_depth, Oid elemtypid, int32 typmod, FmgrInfo finfo, Oid typioparam)

static Datum	plperl_hash_to_datum (SV *src, TupleDesc td)

static void	plperl_init_shared_libs (pTHX)

static void	plperl_trusted_init (void)

static void	plperl_untrusted_init (void)

static HV *	plperl_spi_execute_fetch_result (SPITupleTable *, uint64, int)

static void	plperl_return_next_internal (SV *sv)

static char *	hek2cstr (HE *he)

static SV **	hv_store_string (HV hv, const char key, SV *val)

static SV **	hv_fetch_string (HV hv, const char key)

static void	plperl_create_sub (plperl_proc_desc desc, const char s, Oid fn_oid)

static SV *	plperl_call_perl_func (plperl_proc_desc *desc, FunctionCallInfo fcinfo)

static void	plperl_compile_callback (void *arg)

static void	plperl_exec_callback (void *arg)

static void	plperl_inline_callback (void *arg)

static char *	strip_trailing_ws (const char *msg)

static OP *	pp_require_safe (pTHX)

static void	activate_interpreter (plperl_interp_desc *interp_desc)

static void	SvREFCNT_dec_current (SV *sv)

void	_PG_init (void)

static void	select_perl_context (bool trusted)

static HeapTuple	plperl_build_tuple_result (HV *perlhash, TupleDesc td)

char *	plperl_sv_to_literal (SV sv, char fqtypename)

static SV *	plperl_trigger_build_args (FunctionCallInfo fcinfo)

static SV *	plperl_event_trigger_build_args (FunctionCallInfo fcinfo)

static HeapTuple	plperl_modify_tuple (HV hvTD, TriggerData tdata, HeapTuple otup)

	PG_FUNCTION_INFO_V1 (plperl_call_handler)

Datum	plperl_call_handler (PG_FUNCTION_ARGS)

	PG_FUNCTION_INFO_V1 (plperl_inline_handler)

Datum	plperl_inline_handler (PG_FUNCTION_ARGS)

	PG_FUNCTION_INFO_V1 (plperl_validator)

Datum	plperl_validator (PG_FUNCTION_ARGS)

	PG_FUNCTION_INFO_V1 (plperlu_call_handler)

Datum	plperlu_call_handler (PG_FUNCTION_ARGS)

	PG_FUNCTION_INFO_V1 (plperlu_inline_handler)

Datum	plperlu_inline_handler (PG_FUNCTION_ARGS)

	PG_FUNCTION_INFO_V1 (plperlu_validator)

Datum	plperlu_validator (PG_FUNCTION_ARGS)

static SV *	plperl_call_perl_trigger_func (plperl_proc_desc desc, FunctionCallInfo fcinfo, SV td)

static void	plperl_call_perl_event_trigger_func (plperl_proc_desc desc, FunctionCallInfo fcinfo, SV td)

static bool	validate_plperl_function (plperl_proc_ptr *proc_ptr, HeapTuple procTup)

HV *	plperl_spi_exec (char *query, int limit)

void	plperl_return_next (SV *sv)

SV *	plperl_spi_query (char *query)

SV *	plperl_spi_fetchrow (char *cursor)

void	plperl_spi_cursor_close (char *cursor)

SV *	plperl_spi_prepare (char query, int argc, SV *argv)

HV *	plperl_spi_exec_prepared (char query, HV attr, int argc, SV **argv)

SV *	plperl_spi_query_prepared (char query, int argc, SV *argv)

void	plperl_spi_freeplan (char *query)

void	plperl_spi_commit (void)

void	plperl_spi_rollback (void)

void	plperl_util_elog (int level, SV *msg)

Variables
	PG_MODULE_MAGIC

static HTAB *	plperl_interp_hash = NULL

static HTAB *	plperl_proc_hash = NULL

static plperl_interp_desc *	plperl_active_interp = NULL

static PerlInterpreter *	plperl_held_interp = NULL

static bool	plperl_use_strict = false

static char *	plperl_on_init = NULL

static char *	plperl_on_plperl_init = NULL

static char *	plperl_on_plperlu_init = NULL

static bool	plperl_ending = false

static OP (	pp_require_orig )(pTHX) = NULL

static char	plperl_opmask [MAXO]

static plperl_call_data *	current_call_data = NULL

Macro Definition Documentation

◆ decrement_prodesc_refcount

#define decrement_prodesc_refcount ( prodesc )

Value:

    do { \
        Assert((prodesc)->fn_refcount > 0); \
        if (--((prodesc)->fn_refcount) == 0) \
            free_plperl_function(prodesc); \
    } while(0)

Definition at line 129 of file plperl.c.

◆ increment_prodesc_refcount

#define increment_prodesc_refcount ( prodesc ) ((prodesc)->fn_refcount++)

Definition at line 127 of file plperl.c.

◆ setlocale_perl

#define setlocale_perl	(	a,
		b
	)	Perl_setlocale(a,b)

Definition at line 302 of file plperl.c.

◆ TEXTDOMAIN

#define TEXTDOMAIN PG_TEXTDOMAIN("plperl")

Definition at line 43 of file plperl.c.

Typedef Documentation

◆ plperl_array_info

typedef struct plperl_array_info plperl_array_info

◆ plperl_call_data

typedef struct plperl_call_data plperl_call_data

◆ plperl_interp_desc

typedef struct plperl_interp_desc plperl_interp_desc

◆ plperl_proc_desc

typedef struct plperl_proc_desc plperl_proc_desc

◆ plperl_proc_key

typedef struct plperl_proc_key plperl_proc_key

◆ plperl_proc_ptr

typedef struct plperl_proc_ptr plperl_proc_ptr

◆ plperl_query_desc

typedef struct plperl_query_desc plperl_query_desc

◆ plperl_query_entry

typedef struct plperl_query_entry plperl_query_entry

Function Documentation

◆ _PG_init()

void _PG_init ( void )

Definition at line 380 of file plperl.c.

 {
     /*
      * Be sure we do initialization only once.
      *
      * If initialization fails due to, e.g., plperl_init_interp() throwing an
      * exception, then we'll return here on the next usage and the user will
      * get a rather cryptic: ERROR:  attempt to redefine parameter
      * "plperl.use_strict"
      */
     static bool inited = false;
     HASHCTL     hash_ctl;
  
     if (inited)
         return;
  
     /*
      * Support localized messages.
      */
     pg_bindtextdomain(TEXTDOMAIN);
  
     /*
      * Initialize plperl's GUCs.
      */
     DefineCustomBoolVariable("plperl.use_strict",
                              gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
                              NULL,
                              &plperl_use_strict,
                              false,
                              PGC_USERSET, 0,
                              NULL, NULL, NULL);
  
     /*
      * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
      * be executed in the postmaster (if plperl is loaded into the postmaster
      * via shared_preload_libraries).  This isn't really right either way,
      * though.
      */
     DefineCustomStringVariable("plperl.on_init",
                                gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
                                NULL,
                                &plperl_on_init,
                                NULL,
                                PGC_SIGHUP, 0,
                                NULL, NULL, NULL);
  
     /*
      * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
      * user who might not even have USAGE privilege on the plperl language
      * could nonetheless use SET plperl.on_plperl_init='...' to influence the
      * behaviour of any existing plperl function that they can execute (which
      * might be SECURITY DEFINER, leading to a privilege escalation).  See
      * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
      * the overall thread.
      *
      * Note that because plperl.use_strict is USERSET, a nefarious user could
      * set it to be applied against other people's functions.  This is judged
      * OK since the worst result would be an error.  Your code oughta pass
      * use_strict anyway ;-)
      */
     DefineCustomStringVariable("plperl.on_plperl_init",
                                gettext_noop("Perl initialization code to execute once when plperl is first used."),
                                NULL,
                                &plperl_on_plperl_init,
                                NULL,
                                PGC_SUSET, 0,
                                NULL, NULL, NULL);
  
     DefineCustomStringVariable("plperl.on_plperlu_init",
                                gettext_noop("Perl initialization code to execute once when plperlu is first used."),
                                NULL,
                                &plperl_on_plperlu_init,
                                NULL,
                                PGC_SUSET, 0,
                                NULL, NULL, NULL);
  
     MarkGUCPrefixReserved("plperl");
  
     /*
      * Create hash tables.
      */
     hash_ctl.keysize = sizeof(Oid);
     hash_ctl.entrysize = sizeof(plperl_interp_desc);
     plperl_interp_hash = hash_create("PL/Perl interpreters",
                                      8,
                                      &hash_ctl,
                                      HASH_ELEM | HASH_BLOBS);
  
     hash_ctl.keysize = sizeof(plperl_proc_key);
     hash_ctl.entrysize = sizeof(plperl_proc_ptr);
     plperl_proc_hash = hash_create("PL/Perl procedures",
                                    32,
                                    &hash_ctl,
                                    HASH_ELEM | HASH_BLOBS);
  
     /*
      * Save the default opmask.
      */
     PLPERL_SET_OPMASK(plperl_opmask);
  
     /*
      * Create the first Perl interpreter, but only partially initialize it.
      */
     plperl_held_interp = plperl_init_interp();
  
     inited = true;
 }

References DefineCustomBoolVariable(), DefineCustomStringVariable(), HASHCTL::entrysize, gettext_noop, HASH_BLOBS, hash_create(), HASH_ELEM, HASHCTL::keysize, MarkGUCPrefixReserved(), pg_bindtextdomain(), PGC_SIGHUP, PGC_SUSET, PGC_USERSET, plperl_held_interp, plperl_init_interp(), plperl_interp_hash, plperl_on_init, plperl_on_plperl_init, plperl_on_plperlu_init, plperl_opmask, plperl_proc_hash, plperl_use_strict, and TEXTDOMAIN.

◆ _sv_to_datum_finfo()

static void _sv_to_datum_finfo	(	Oid	typid,
		FmgrInfo *	finfo,
		Oid *	typioparam
	)

static

Definition at line 1300 of file plperl.c.

 {
     Oid         typinput;
  
     /* XXX would be better to cache these lookups */
     getTypeInputInfo(typid,
                      &typinput, typioparam);
     fmgr_info(typinput, finfo);
 }

References fmgr_info(), and getTypeInputInfo().

Referenced by plperl_array_to_datum(), and plperl_sv_to_datum().

◆ activate_interpreter()

static void activate_interpreter ( plperl_interp_desc * interp_desc )

static

Definition at line 684 of file plperl.c.

 {
     if (interp_desc && plperl_active_interp != interp_desc)
     {
         Assert(interp_desc->interp);
         PERL_SET_CONTEXT(interp_desc->interp);
         /* trusted iff user_id isn't InvalidOid */
         set_interp_require(OidIsValid(interp_desc->user_id));
         plperl_active_interp = interp_desc;
     }
 }

References Assert, plperl_interp_desc::interp, OidIsValid, plperl_active_interp, set_interp_require(), and plperl_interp_desc::user_id.

Referenced by compile_plperl_function(), free_plperl_function(), plperl_call_handler(), plperl_event_trigger_handler(), plperl_fini(), plperl_func_handler(), plperl_inline_handler(), plperl_trigger_handler(), and select_perl_context().

◆ array_to_datum_internal()

static void array_to_datum_internal	(	AV *	av,
		ArrayBuildState **	astatep,
		int *	ndims,
		int *	dims,
		int	cur_depth,
		Oid	elemtypid,
		int32	typmod,
		FmgrInfo *	finfo,
		Oid	typioparam
	)

static

Definition at line 1170 of file plperl.c.

 {
     dTHX;
     int         i;
     int         len = av_len(av) + 1;
  
     for (i = 0; i < len; i++)
     {
         /* fetch the array element */
         SV        **svp = av_fetch(av, i, FALSE);
  
         /* see if this element is an array, if so get that */
         SV         *sav = svp ? get_perl_array_ref(*svp) : NULL;
  
         /* multi-dimensional array? */
         if (sav)
         {
             AV         *nav = (AV *) SvRV(sav);
  
             /* set size when at first element in this level, else compare */
             if (i == 0 && *ndims == cur_depth)
             {
                 /* array after some scalars at same level? */
                 if (*astatep != NULL)
                     ereport(ERROR,
                             (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
                              errmsg("multidimensional arrays must have array expressions with matching dimensions")));
                 /* too many dimensions? */
                 if (cur_depth + 1 > MAXDIM)
                     ereport(ERROR,
                             (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
                              errmsg("number of array dimensions exceeds the maximum allowed (%d)",
                                     MAXDIM)));
                 /* OK, add a dimension */
                 dims[*ndims] = av_len(nav) + 1;
                 (*ndims)++;
             }
             else if (cur_depth >= *ndims ||
                      av_len(nav) + 1 != dims[cur_depth])
                 ereport(ERROR,
                         (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
                          errmsg("multidimensional arrays must have array expressions with matching dimensions")));
  
             /* recurse to fetch elements of this sub-array */
             array_to_datum_internal(nav, astatep,
                                     ndims, dims, cur_depth + 1,
                                     elemtypid, typmod,
                                     finfo, typioparam);
         }
         else
         {
             Datum       dat;
             bool        isnull;
  
             /* scalar after some sub-arrays at same level? */
             if (*ndims != cur_depth)
                 ereport(ERROR,
                         (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
                          errmsg("multidimensional arrays must have array expressions with matching dimensions")));
  
             dat = plperl_sv_to_datum(svp ? *svp : NULL,
                                      elemtypid,
                                      typmod,
                                      NULL,
                                      finfo,
                                      typioparam,
                                      &isnull);
  
             /* Create ArrayBuildState if we didn't already */
             if (*astatep == NULL)
                 *astatep = initArrayResult(elemtypid,
                                            CurrentMemoryContext, true);
  
             /* ... and save the element value in it */
             (void) accumArrayResult(*astatep, dat, isnull,
                                     elemtypid, CurrentMemoryContext);
         }
     }
 }

References accumArrayResult(), av, CurrentMemoryContext, dTHX, ereport, errcode(), errmsg(), ERROR, get_perl_array_ref(), i, initArrayResult(), len, MAXDIM, and plperl_sv_to_datum().

Referenced by plperl_array_to_datum().

◆ boot_DynaLoader()

EXTERN_C void boot_DynaLoader ( pTHX_ CV * cv )

Referenced by plperl_init_shared_libs().

◆ boot_PostgreSQLInServerSPI()

EXTERN_C void boot_PostgreSQL__InServer__SPI ( pTHX_ CV * cv )

Referenced by select_perl_context().

◆ boot_PostgreSQLInServerUtil()

EXTERN_C void boot_PostgreSQL__InServer__Util ( pTHX_ CV * cv )

Referenced by plperl_init_shared_libs().

◆ check_spi_usage_allowed()

static void check_spi_usage_allowed ( void )

static

Definition at line 3106 of file plperl.c.

 {
     /* see comment in plperl_fini() */
     if (plperl_ending)
     {
         /* simple croak as we don't want to involve PostgreSQL code */
         croak("SPI functions can not be used in END blocks");
     }
  
     /*
      * Disallow SPI usage if we're not executing a fully-compiled plperl
      * function.  It might seem impossible to get here in that case, but there
      * are cases where Perl will try to execute code during compilation.  If
      * we proceed we are likely to crash trying to dereference the prodesc
      * pointer.  Working around that might be possible, but it seems unwise
      * because it'd allow code execution to happen while validating a
      * function, which is undesirable.
      */
     if (current_call_data == NULL || current_call_data->prodesc == NULL)
     {
         /* simple croak as we don't want to involve PostgreSQL code */
         croak("SPI functions can not be used during function compilation");
     }
 }

References current_call_data, plperl_ending, and plperl_call_data::prodesc.

Referenced by plperl_return_next(), plperl_spi_commit(), plperl_spi_cursor_close(), plperl_spi_exec(), plperl_spi_exec_prepared(), plperl_spi_execute_fetch_result(), plperl_spi_fetchrow(), plperl_spi_freeplan(), plperl_spi_prepare(), plperl_spi_query(), plperl_spi_query_prepared(), plperl_spi_rollback(), and plperl_sv_to_literal().

◆ compile_plperl_function()

static plperl_proc_desc * compile_plperl_function	(	Oid	fn_oid,
		bool	is_trigger,
		bool	is_event_trigger
	)

static

Definition at line 2718 of file plperl.c.

 {
     HeapTuple   procTup;
     Form_pg_proc procStruct;
     plperl_proc_key proc_key;
     plperl_proc_ptr *proc_ptr;
     plperl_proc_desc *volatile prodesc = NULL;
     volatile MemoryContext proc_cxt = NULL;
     plperl_interp_desc *oldinterp = plperl_active_interp;
     ErrorContextCallback plperl_error_context;
  
     /* We'll need the pg_proc tuple in any case... */
     procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
     if (!HeapTupleIsValid(procTup))
         elog(ERROR, "cache lookup failed for function %u", fn_oid);
     procStruct = (Form_pg_proc) GETSTRUCT(procTup);
  
     /*
      * Try to find function in plperl_proc_hash.  The reason for this
      * overcomplicated-seeming lookup procedure is that we don't know whether
      * it's plperl or plperlu, and don't want to spend a lookup in pg_language
      * to find out.
      */
     proc_key.proc_id = fn_oid;
     proc_key.is_trigger = is_trigger;
     proc_key.user_id = GetUserId();
     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
                            HASH_FIND, NULL);
     if (validate_plperl_function(proc_ptr, procTup))
     {
         /* Found valid plperl entry */
         ReleaseSysCache(procTup);
         return proc_ptr->proc_ptr;
     }
  
     /* If not found or obsolete, maybe it's plperlu */
     proc_key.user_id = InvalidOid;
     proc_ptr = hash_search(plperl_proc_hash, &proc_key,
                            HASH_FIND, NULL);
     if (validate_plperl_function(proc_ptr, procTup))
     {
         /* Found valid plperlu entry */
         ReleaseSysCache(procTup);
         return proc_ptr->proc_ptr;
     }
  
     /************************************************************
      * If we haven't found it in the hashtable, we analyze
      * the function's arguments and return type and store
      * the in-/out-functions in the prodesc block,
      * then we load the procedure into the Perl interpreter,
      * and last we create a new hashtable entry for it.
      ************************************************************/
  
     /* Set a callback for reporting compilation errors */
     plperl_error_context.callback = plperl_compile_callback;
     plperl_error_context.previous = error_context_stack;
     plperl_error_context.arg = NameStr(procStruct->proname);
     error_context_stack = &plperl_error_context;
  
     PG_TRY();
     {
         HeapTuple   langTup;
         HeapTuple   typeTup;
         Form_pg_language langStruct;
         Form_pg_type typeStruct;
         Datum       protrftypes_datum;
         Datum       prosrcdatum;
         bool        isnull;
         char       *proc_source;
         MemoryContext oldcontext;
  
         /************************************************************
          * Allocate a context that will hold all PG data for the procedure.
          ************************************************************/
         proc_cxt = AllocSetContextCreate(TopMemoryContext,
                                          "PL/Perl function",
                                          ALLOCSET_SMALL_SIZES);
  
         /************************************************************
          * Allocate and fill a new procedure description block.
          * struct prodesc and subsidiary data must all live in proc_cxt.
          ************************************************************/
         oldcontext = MemoryContextSwitchTo(proc_cxt);
         prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc));
         prodesc->proname = pstrdup(NameStr(procStruct->proname));
         MemoryContextSetIdentifier(proc_cxt, prodesc->proname);
         prodesc->fn_cxt = proc_cxt;
         prodesc->fn_refcount = 0;
         prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
         prodesc->fn_tid = procTup->t_self;
         prodesc->nargs = procStruct->pronargs;
         prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
         prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
         prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid));
         MemoryContextSwitchTo(oldcontext);
  
         /* Remember if function is STABLE/IMMUTABLE */
         prodesc->fn_readonly =
             (procStruct->provolatile != PROVOLATILE_VOLATILE);
  
         /* Fetch protrftypes */
         protrftypes_datum = SysCacheGetAttr(PROCOID, procTup,
                                             Anum_pg_proc_protrftypes, &isnull);
         MemoryContextSwitchTo(proc_cxt);
         prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum);
         MemoryContextSwitchTo(oldcontext);
  
         /************************************************************
          * Lookup the pg_language tuple by Oid
          ************************************************************/
         langTup = SearchSysCache1(LANGOID,
                                   ObjectIdGetDatum(procStruct->prolang));
         if (!HeapTupleIsValid(langTup))
             elog(ERROR, "cache lookup failed for language %u",
                  procStruct->prolang);
         langStruct = (Form_pg_language) GETSTRUCT(langTup);
         prodesc->lang_oid = langStruct->oid;
         prodesc->lanpltrusted = langStruct->lanpltrusted;
         ReleaseSysCache(langTup);
  
         /************************************************************
          * Get the required information for input conversion of the
          * return value.
          ************************************************************/
         if (!is_trigger && !is_event_trigger)
         {
             Oid         rettype = procStruct->prorettype;
  
             typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
             if (!HeapTupleIsValid(typeTup))
                 elog(ERROR, "cache lookup failed for type %u", rettype);
             typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
             /* Disallow pseudotype result, except VOID or RECORD */
             if (typeStruct->typtype == TYPTYPE_PSEUDO)
             {
                 if (rettype == VOIDOID ||
                     rettype == RECORDOID)
                      /* okay */ ;
                 else if (rettype == TRIGGEROID ||
                          rettype == EVENT_TRIGGEROID)
                     ereport(ERROR,
                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                              errmsg("trigger functions can only be called "
                                     "as triggers")));
                 else
                     ereport(ERROR,
                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                              errmsg("PL/Perl functions cannot return type %s",
                                     format_type_be(rettype))));
             }
  
             prodesc->result_oid = rettype;
             prodesc->fn_retisset = procStruct->proretset;
             prodesc->fn_retistuple = type_is_rowtype(rettype);
             prodesc->fn_retisarray = IsTrueArrayType(typeStruct);
  
             fmgr_info_cxt(typeStruct->typinput,
                           &(prodesc->result_in_func),
                           proc_cxt);
             prodesc->result_typioparam = getTypeIOParam(typeTup);
  
             ReleaseSysCache(typeTup);
         }
  
         /************************************************************
          * Get the required information for output conversion
          * of all procedure arguments
          ************************************************************/
         if (!is_trigger && !is_event_trigger)
         {
             int         i;
  
             for (i = 0; i < prodesc->nargs; i++)
             {
                 Oid         argtype = procStruct->proargtypes.values[i];
  
                 typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
                 if (!HeapTupleIsValid(typeTup))
                     elog(ERROR, "cache lookup failed for type %u", argtype);
                 typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
  
                 /* Disallow pseudotype argument, except RECORD */
                 if (typeStruct->typtype == TYPTYPE_PSEUDO &&
                     argtype != RECORDOID)
                     ereport(ERROR,
                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                              errmsg("PL/Perl functions cannot accept type %s",
                                     format_type_be(argtype))));
  
                 if (type_is_rowtype(argtype))
                     prodesc->arg_is_rowtype[i] = true;
                 else
                 {
                     prodesc->arg_is_rowtype[i] = false;
                     fmgr_info_cxt(typeStruct->typoutput,
                                   &(prodesc->arg_out_func[i]),
                                   proc_cxt);
                 }
  
                 /* Identify array-type arguments */
                 if (IsTrueArrayType(typeStruct))
                     prodesc->arg_arraytype[i] = argtype;
                 else
                     prodesc->arg_arraytype[i] = InvalidOid;
  
                 ReleaseSysCache(typeTup);
             }
         }
  
         /************************************************************
          * create the text of the anonymous subroutine.
          * we do not use a named subroutine so that we can call directly
          * through the reference.
          ************************************************************/
         prosrcdatum = SysCacheGetAttrNotNull(PROCOID, procTup,
                                              Anum_pg_proc_prosrc);
         proc_source = TextDatumGetCString(prosrcdatum);
  
         /************************************************************
          * Create the procedure in the appropriate interpreter
          ************************************************************/
  
         select_perl_context(prodesc->lanpltrusted);
  
         prodesc->interp = plperl_active_interp;
  
         plperl_create_sub(prodesc, proc_source, fn_oid);
  
         activate_interpreter(oldinterp);
  
         pfree(proc_source);
  
         if (!prodesc->reference)    /* can this happen? */
             elog(ERROR, "could not create PL/Perl internal procedure");
  
         /************************************************************
          * OK, link the procedure into the correct hashtable entry.
          * Note we assume that the hashtable entry either doesn't exist yet,
          * or we already cleared its proc_ptr during the validation attempts
          * above.  So no need to decrement an old refcount here.
          ************************************************************/
         proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
  
         proc_ptr = hash_search(plperl_proc_hash, &proc_key,
                                HASH_ENTER, NULL);
         /* We assume these two steps can't throw an error: */
         proc_ptr->proc_ptr = prodesc;
         increment_prodesc_refcount(prodesc);
     }
     PG_CATCH();
     {
         /*
          * If we got as far as creating a reference, we should be able to use
          * free_plperl_function() to clean up.  If not, then at most we have
          * some PG memory resources in proc_cxt, which we can just delete.
          */
         if (prodesc && prodesc->reference)
             free_plperl_function(prodesc);
         else if (proc_cxt)
             MemoryContextDelete(proc_cxt);
  
         /* Be sure to restore the previous interpreter, too, for luck */
         activate_interpreter(oldinterp);
  
         PG_RE_THROW();
     }
     PG_END_TRY();
  
     /* restore previous error callback */
     error_context_stack = plperl_error_context.previous;
  
     ReleaseSysCache(procTup);
  
     return prodesc;
 }

Referenced by plperl_event_trigger_handler(), plperl_func_handler(), plperl_trigger_handler(), and plperl_validator().

◆ free_plperl_function()

static void free_plperl_function ( plperl_proc_desc * prodesc )

static

Definition at line 2700 of file plperl.c.

 {
     Assert(prodesc->fn_refcount == 0);
     /* Release CODE reference, if we have one, from the appropriate interp */
     if (prodesc->reference)
     {
         plperl_interp_desc *oldinterp = plperl_active_interp;
  
         activate_interpreter(prodesc->interp);
         SvREFCNT_dec_current(prodesc->reference);
         activate_interpreter(oldinterp);
     }
     /* Release all PG-owned data for this proc */
     MemoryContextDelete(prodesc->fn_cxt);
 }

References activate_interpreter(), Assert, plperl_proc_desc::fn_cxt, plperl_proc_desc::fn_refcount, plperl_proc_desc::interp, MemoryContextDelete(), plperl_active_interp, plperl_proc_desc::reference, and SvREFCNT_dec_current().

Referenced by compile_plperl_function().

◆ get_perl_array_ref()

static SV * get_perl_array_ref ( SV * sv )

static

Definition at line 1138 of file plperl.c.

 {
     dTHX;
  
     if (SvOK(sv) && SvROK(sv))
     {
         if (SvTYPE(SvRV(sv)) == SVt_PVAV)
             return sv;
         else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY"))
         {
             HV         *hv = (HV *) SvRV(sv);
             SV        **sav = hv_fetch_string(hv, "array");
  
             if (*sav && SvOK(*sav) && SvROK(*sav) &&
                 SvTYPE(SvRV(*sav)) == SVt_PVAV)
                 return *sav;
  
             elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
         }
     }
     return NULL;
 }

References dTHX, elog, ERROR, and hv_fetch_string().

Referenced by array_to_datum_internal(), plperl_func_handler(), and plperl_sv_to_datum().

◆ hek2cstr()

static char * hek2cstr ( HE * he )

static

Definition at line 323 of file plperl.c.

 {
     dTHX;
     char       *ret;
     SV         *sv;
  
     /*
      * HeSVKEY_force will return a temporary mortal SV*, so we need to make
      * sure to free it with ENTER/SAVE/FREE/LEAVE
      */
     ENTER;
     SAVETMPS;
  
     /*-------------------------
      * Unfortunately, while HeUTF8 is true for most things > 256, for values
      * 128..255 it's not, but perl will treat them as unicode code points if
      * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
      * for more)
      *
      * So if we did the expected:
      *    if (HeUTF8(he))
      *        utf_u2e(key...);
      *    else // must be ascii
      *        return HePV(he);
      * we won't match columns with codepoints from 128..255
      *
      * For a more concrete example given a column with the name of the unicode
      * codepoint U+00ae (registered sign) and a UTF8 database and the perl
      * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
      * 0 and HePV() would give us a char * with 1 byte contains the decimal
      * value 174
      *
      * Perl has the brains to know when it should utf8 encode 174 properly, so
      * here we force it into an SV so that perl will figure it out and do the
      * right thing
      *-------------------------
      */
  
     sv = HeSVKEY_force(he);
     if (HeUTF8(he))
         SvUTF8_on(sv);
     ret = sv2cstr(sv);
  
     /* free sv */
     FREETMPS;
     LEAVE;
  
     return ret;
 }

References dTHX, HeUTF8, and sv2cstr().

Referenced by plperl_build_tuple_result(), and plperl_modify_tuple().

◆ hv_fetch_string()

static SV ** hv_fetch_string	(	HV *	hv,
		const char *	key
	)

static

Definition at line 4120 of file plperl.c.

 {
     dTHX;
     int32       hlen;
     char       *hkey;
     SV        **ret;
  
     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
  
     /* See notes in hv_store_string */
     hlen = -(int) strlen(hkey);
     ret = hv_fetch(hv, hkey, hlen, 0);
  
     if (hkey != key)
         pfree(hkey);
  
     return ret;
 }

References dTHX, sort-test::key, pfree(), pg_server_to_any(), and PG_UTF8.

Referenced by get_perl_array_ref(), plperl_modify_tuple(), and plperl_spi_exec_prepared().

◆ hv_store_string()

static SV ** hv_store_string	(	HV *	hv,
		const char *	key,
		SV *	val
	)

static

Definition at line 4093 of file plperl.c.

 {
     dTHX;
     int32       hlen;
     char       *hkey;
     SV        **ret;
  
     hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
  
     /*
      * hv_store() recognizes a negative klen parameter as meaning a UTF-8
      * encoded key.
      */
     hlen = -(int) strlen(hkey);
     ret = hv_store(hv, hkey, hlen, val, 0);
  
     if (hkey != key)
         pfree(hkey);
  
     return ret;
 }

References dTHX, sort-test::key, pfree(), pg_server_to_any(), PG_UTF8, and val.

Referenced by plperl_create_sub(), plperl_event_trigger_build_args(), plperl_hash_from_tuple(), plperl_spi_execute_fetch_result(), and plperl_trigger_build_args().

◆ make_array_ref()

static SV * make_array_ref	(	plperl_array_info *	info,
		int	first,
		int	last
	)

static

Definition at line 1593 of file plperl.c.

 {
     dTHX;
     int         i;
     AV         *result = newAV();
  
     for (i = first; i < last; i++)
     {
         if (info->nulls[i])
         {
             /*
              * We can't use &PL_sv_undef here.  See "AVs, HVs and undefined
              * values" in perlguts.
              */
             av_push(result, newSV(0));
         }
         else
         {
             Datum       itemvalue = info->elements[i];
  
             if (info->transform_proc.fn_oid)
                 av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue)));
             else if (info->elem_is_rowtype)
                 /* Handle composite type elements */
                 av_push(result, plperl_hash_from_datum(itemvalue));
             else
             {
                 char       *val = OutputFunctionCall(&info->proc, itemvalue);
  
                 av_push(result, cstr2sv(val));
             }
         }
     }
     return newRV_noinc((SV *) result);
 }

References cstr2sv(), DatumGetPointer(), dTHX, plperl_array_info::elem_is_rowtype, plperl_array_info::elements, FmgrInfo::fn_oid, FunctionCall1, i, newRV_noinc, plperl_array_info::nulls, OutputFunctionCall(), plperl_hash_from_datum(), plperl_array_info::proc, plperl_array_info::transform_proc, and val.

Referenced by split_array().

◆ PG_FUNCTION_INFO_V1() [1/6]

PG_FUNCTION_INFO_V1 ( plperl_call_handler )

◆ PG_FUNCTION_INFO_V1() [2/6]

PG_FUNCTION_INFO_V1 ( plperl_inline_handler )

◆ PG_FUNCTION_INFO_V1() [3/6]

PG_FUNCTION_INFO_V1 ( plperl_validator )

◆ PG_FUNCTION_INFO_V1() [4/6]

PG_FUNCTION_INFO_V1 ( plperlu_call_handler )

◆ PG_FUNCTION_INFO_V1() [5/6]

PG_FUNCTION_INFO_V1 ( plperlu_inline_handler )

◆ PG_FUNCTION_INFO_V1() [6/6]

PG_FUNCTION_INFO_V1 ( plperlu_validator )

◆ plperl_array_to_datum()

static Datum plperl_array_to_datum	(	SV *	src,
		Oid	typid,
		int32	typmod
	)

static

Definition at line 1257 of file plperl.c.

 {
     dTHX;
     AV         *nav = (AV *) SvRV(src);
     ArrayBuildState *astate = NULL;
     Oid         elemtypid;
     FmgrInfo    finfo;
     Oid         typioparam;
     int         dims[MAXDIM];
     int         lbs[MAXDIM];
     int         ndims = 1;
     int         i;
  
     elemtypid = get_element_type(typid);
     if (!elemtypid)
         ereport(ERROR,
                 (errcode(ERRCODE_DATATYPE_MISMATCH),
                  errmsg("cannot convert Perl array to non-array type %s",
                         format_type_be(typid))));
  
     _sv_to_datum_finfo(elemtypid, &finfo, &typioparam);
  
     memset(dims, 0, sizeof(dims));
     dims[0] = av_len(nav) + 1;
  
     array_to_datum_internal(nav, &astate,
                             &ndims, dims, 1,
                             elemtypid, typmod,
                             &finfo, typioparam);
  
     /* ensure we get zero-D array for no inputs, as per PG convention */
     if (astate == NULL)
         return PointerGetDatum(construct_empty_array(elemtypid));
  
     for (i = 0; i < ndims; i++)
         lbs[i] = 1;
  
     return makeMdArrayResult(astate, ndims, dims, lbs,
                              CurrentMemoryContext, true);
 }

References _sv_to_datum_finfo(), array_to_datum_internal(), construct_empty_array(), CurrentMemoryContext, dTHX, ereport, errcode(), errmsg(), ERROR, format_type_be(), get_element_type(), i, makeMdArrayResult(), MAXDIM, and PointerGetDatum().

Referenced by plperl_sv_to_datum().

◆ plperl_build_tuple_result()

static HeapTuple plperl_build_tuple_result	(	HV *	perlhash,
		TupleDesc	td
	)

static

Definition at line 1075 of file plperl.c.

 {
     dTHX;
     Datum      *values;
     bool       *nulls;
     HE         *he;
     HeapTuple   tup;
  
     values = palloc0(sizeof(Datum) * td->natts);
     nulls = palloc(sizeof(bool) * td->natts);
     memset(nulls, true, sizeof(bool) * td->natts);
  
     hv_iterinit(perlhash);
     while ((he = hv_iternext(perlhash)))
     {
         SV         *val = HeVAL(he);
         char       *key = hek2cstr(he);
         int         attn = SPI_fnumber(td, key);
         Form_pg_attribute attr = TupleDescAttr(td, attn - 1);
  
         if (attn == SPI_ERROR_NOATTRIBUTE)
             ereport(ERROR,
                     (errcode(ERRCODE_UNDEFINED_COLUMN),
                      errmsg("Perl hash contains nonexistent column \"%s\"",
                             key)));
         if (attn <= 0)
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("cannot set system attribute \"%s\"",
                             key)));
  
         values[attn - 1] = plperl_sv_to_datum(val,
                                               attr->atttypid,
                                               attr->atttypmod,
                                               NULL,
                                               NULL,
                                               InvalidOid,
                                               &nulls[attn - 1]);
  
         pfree(key);
     }
     hv_iterinit(perlhash);
  
     tup = heap_form_tuple(td, values, nulls);
     pfree(values);
     pfree(nulls);
     return tup;
 }

References dTHX, ereport, errcode(), errmsg(), ERROR, heap_form_tuple(), hek2cstr(), InvalidOid, sort-test::key, TupleDescData::natts, palloc(), palloc0(), pfree(), plperl_sv_to_datum(), SPI_ERROR_NOATTRIBUTE, SPI_fnumber(), TupleDescAttr, val, and values.

Referenced by plperl_hash_to_datum(), and plperl_return_next_internal().

◆ plperl_call_handler()

Datum plperl_call_handler ( PG_FUNCTION_ARGS )

Definition at line 1852 of file plperl.c.

 {
     Datum       retval = (Datum) 0;
     plperl_call_data *volatile save_call_data = current_call_data;
     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
     plperl_call_data this_call_data;
  
     /* Initialize current-call status record */
     MemSet(&this_call_data, 0, sizeof(this_call_data));
     this_call_data.fcinfo = fcinfo;
  
     PG_TRY();
     {
         current_call_data = &this_call_data;
         if (CALLED_AS_TRIGGER(fcinfo))
             retval = plperl_trigger_handler(fcinfo);
         else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
         {
             plperl_event_trigger_handler(fcinfo);
             retval = (Datum) 0;
         }
         else
             retval = plperl_func_handler(fcinfo);
     }
     PG_FINALLY();
     {
         current_call_data = save_call_data;
         activate_interpreter(oldinterp);
         if (this_call_data.prodesc)
             decrement_prodesc_refcount(this_call_data.prodesc);
     }
     PG_END_TRY();
  
     return retval;
 }

References activate_interpreter(), CALLED_AS_EVENT_TRIGGER, CALLED_AS_TRIGGER, current_call_data, decrement_prodesc_refcount, plperl_call_data::fcinfo, MemSet, PG_END_TRY, PG_FINALLY, PG_TRY, plperl_active_interp, plperl_event_trigger_handler(), plperl_func_handler(), plperl_trigger_handler(), and plperl_call_data::prodesc.

Referenced by plperlu_call_handler().

◆ plperl_call_perl_event_trigger_func()

static void plperl_call_perl_event_trigger_func	(	plperl_proc_desc *	desc,
		FunctionCallInfo	fcinfo,
		SV *	td
	)

static

Definition at line 2341 of file plperl.c.

 {
     dTHX;
     dSP;
     SV         *retval,
                *TDsv;
     int         count;
  
     ENTER;
     SAVETMPS;
  
     TDsv = get_sv("main::_TD", 0);
     if (!TDsv)
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("couldn't fetch $_TD")));
  
     save_item(TDsv);            /* local $_TD */
     sv_setsv(TDsv, td);
  
     PUSHMARK(sp);
     PUTBACK;
  
     /* Do NOT use G_KEEPERR here */
     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
  
     SPAGAIN;
  
     if (count != 1)
     {
         PUTBACK;
         FREETMPS;
         LEAVE;
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("didn't get a return item from trigger function")));
     }
  
     if (SvTRUE(ERRSV))
     {
         (void) POPs;
         PUTBACK;
         FREETMPS;
         LEAVE;
         /* XXX need to find a way to determine a better errcode here */
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
     }
  
     retval = newSVsv(POPs);
     (void) retval;              /* silence compiler warning */
  
     PUTBACK;
     FREETMPS;
     LEAVE;
 }

References call_sv, dTHX, ereport, errcode(), errmsg(), ERROR, ERRSV, get_sv, plperl_proc_desc::reference, strip_trailing_ws(), and sv2cstr().

Referenced by plperl_event_trigger_handler().

◆ plperl_call_perl_func()

static SV * plperl_call_perl_func	(	plperl_proc_desc *	desc,
		FunctionCallInfo	fcinfo
	)

static

Definition at line 2180 of file plperl.c.

 {
     dTHX;
     dSP;
     SV         *retval;
     int         i;
     int         count;
     Oid        *argtypes = NULL;
     int         nargs = 0;
  
     ENTER;
     SAVETMPS;
  
     PUSHMARK(SP);
     EXTEND(sp, desc->nargs);
  
     /* Get signature for true functions; inline blocks have no args. */
     if (fcinfo->flinfo->fn_oid)
         get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs);
     Assert(nargs == desc->nargs);
  
     for (i = 0; i < desc->nargs; i++)
     {
         if (fcinfo->args[i].isnull)
             PUSHs(&PL_sv_undef);
         else if (desc->arg_is_rowtype[i])
         {
             SV         *sv = plperl_hash_from_datum(fcinfo->args[i].value);
  
             PUSHs(sv_2mortal(sv));
         }
         else
         {
             SV         *sv;
             Oid         funcid;
  
             if (OidIsValid(desc->arg_arraytype[i]))
                 sv = plperl_ref_from_pg_array(fcinfo->args[i].value, desc->arg_arraytype[i]);
             else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->args[i].value));
             else
             {
                 char       *tmp;
  
                 tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
                                          fcinfo->args[i].value);
                 sv = cstr2sv(tmp);
                 pfree(tmp);
             }
  
             PUSHs(sv_2mortal(sv));
         }
     }
     PUTBACK;
  
     /* Do NOT use G_KEEPERR here */
     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
  
     SPAGAIN;
  
     if (count != 1)
     {
         PUTBACK;
         FREETMPS;
         LEAVE;
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("didn't get a return item from function")));
     }
  
     if (SvTRUE(ERRSV))
     {
         (void) POPs;
         PUTBACK;
         FREETMPS;
         LEAVE;
         /* XXX need to find a way to determine a better errcode here */
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
     }
  
     retval = newSVsv(POPs);
  
     PUTBACK;
     FREETMPS;
     LEAVE;
  
     return retval;
 }

References plperl_proc_desc::arg_arraytype, plperl_proc_desc::arg_is_rowtype, plperl_proc_desc::arg_out_func, FunctionCallInfoBaseData::args, Assert, call_sv, cstr2sv(), current_call_data, DatumGetPointer(), dTHX, ereport, errcode(), errmsg(), ERROR, ERRSV, FunctionCallInfoBaseData::flinfo, FmgrInfo::fn_oid, get_func_signature(), get_transform_fromsql(), i, NullableDatum::isnull, plperl_proc_desc::lang_oid, plperl_proc_desc::nargs, OidFunctionCall1, OidIsValid, OutputFunctionCall(), pfree(), PL_sv_undef, plperl_hash_from_datum(), plperl_ref_from_pg_array(), plperl_call_data::prodesc, plperl_proc_desc::reference, strip_trailing_ws(), sv2cstr(), plperl_proc_desc::trftypes, and NullableDatum::value.

Referenced by plperl_func_handler(), and plperl_inline_handler().

◆ plperl_call_perl_trigger_func()

static SV* plperl_call_perl_trigger_func	(	plperl_proc_desc *	desc,
		FunctionCallInfo	fcinfo,
		SV *	td
	)

static

Definition at line 2273 of file plperl.c.

 {
     dTHX;
     dSP;
     SV         *retval,
                *TDsv;
     int         i,
                 count;
     Trigger    *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
  
     ENTER;
     SAVETMPS;
  
     TDsv = get_sv("main::_TD", 0);
     if (!TDsv)
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("couldn't fetch $_TD")));
  
     save_item(TDsv);            /* local $_TD */
     sv_setsv(TDsv, td);
  
     PUSHMARK(sp);
     EXTEND(sp, tg_trigger->tgnargs);
  
     for (i = 0; i < tg_trigger->tgnargs; i++)
         PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
     PUTBACK;
  
     /* Do NOT use G_KEEPERR here */
     count = call_sv(desc->reference, G_SCALAR | G_EVAL);
  
     SPAGAIN;
  
     if (count != 1)
     {
         PUTBACK;
         FREETMPS;
         LEAVE;
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("didn't get a return item from trigger function")));
     }
  
     if (SvTRUE(ERRSV))
     {
         (void) POPs;
         PUTBACK;
         FREETMPS;
         LEAVE;
         /* XXX need to find a way to determine a better errcode here */
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
     }
  
     retval = newSVsv(POPs);
  
     PUTBACK;
     FREETMPS;
     LEAVE;
  
     return retval;
 }

References call_sv, FunctionCallInfoBaseData::context, cstr2sv(), dTHX, ereport, errcode(), errmsg(), ERROR, ERRSV, get_sv, i, plperl_proc_desc::reference, strip_trailing_ws(), sv2cstr(), Trigger::tgargs, and Trigger::tgnargs.

Referenced by plperl_trigger_handler().

◆ plperl_compile_callback()

static void plperl_compile_callback ( void * arg )

static

Definition at line 4155 of file plperl.c.

 {
     char       *procname = (char *) arg;
  
     if (procname)
         errcontext("compilation of PL/Perl function \"%s\"", procname);
 }

References arg, and errcontext.

Referenced by compile_plperl_function().

◆ plperl_create_sub()

static void plperl_create_sub	(	plperl_proc_desc *	desc,
		const char *	s,
		Oid	fn_oid
	)

static

Definition at line 2095 of file plperl.c.

 {
     dTHX;
     dSP;
     char        subname[NAMEDATALEN + 40];
     HV         *pragma_hv = newHV();
     SV         *subref = NULL;
     int         count;
  
     sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
  
     if (plperl_use_strict)
         hv_store_string(pragma_hv, "strict", (SV *) newAV());
  
     ENTER;
     SAVETMPS;
     PUSHMARK(SP);
     EXTEND(SP, 4);
     PUSHs(sv_2mortal(cstr2sv(subname)));
     PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
  
     /*
      * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
      * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
      * compiler.
      */
     PUSHs(&PL_sv_no);
     PUSHs(sv_2mortal(cstr2sv(s)));
     PUTBACK;
  
     /*
      * G_KEEPERR seems to be needed here, else we don't recognize compile
      * errors properly.  Perhaps it's because there's another level of eval
      * inside mkfunc?
      */
     count = call_pv("PostgreSQL::InServer::mkfunc",
                     G_SCALAR | G_EVAL | G_KEEPERR);
     SPAGAIN;
  
     if (count == 1)
     {
         SV         *sub_rv = (SV *) POPs;
  
         if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
         {
             subref = newRV_inc(SvRV(sub_rv));
         }
     }
  
     PUTBACK;
     FREETMPS;
     LEAVE;
  
     if (SvTRUE(ERRSV))
         ereport(ERROR,
                 (errcode(ERRCODE_SYNTAX_ERROR),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV)))));
  
     if (!subref)
         ereport(ERROR,
                 (errcode(ERRCODE_SYNTAX_ERROR),
                  errmsg("didn't get a CODE reference from compiling function \"%s\"",
                         prodesc->proname)));
  
     prodesc->reference = subref;
 }

References call_pv, cstr2sv(), dTHX, ereport, errcode(), errmsg(), ERROR, ERRSV, hv_store_string(), NAMEDATALEN, newRV_inc, newRV_noinc, PL_sv_no, plperl_use_strict, plperl_proc_desc::proname, plperl_proc_desc::reference, sprintf, strip_trailing_ws(), subname, and sv2cstr().

Referenced by compile_plperl_function(), and plperl_inline_handler().

◆ plperl_destroy_interp()

static void plperl_destroy_interp ( PerlInterpreter ** interp )

static

Definition at line 918 of file plperl.c.

 {
     if (interp && *interp)
     {
         /*
          * Only a very minimal destruction is performed: - just call END
          * blocks.
          *
          * We could call perl_destruct() but we'd need to audit its actions
          * very carefully and work-around any that impact us. (Calling
          * sv_clean_objs() isn't an option because it's not part of perl's
          * public API so isn't portably available.) Meanwhile END blocks can
          * be used to perform manual cleanup.
          */
         dTHX;
  
         /* Run END blocks - based on perl's perl_destruct() */
         if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
         {
             dJMPENV;
             int         x = 0;
  
             JMPENV_PUSH(x);
             PERL_UNUSED_VAR(x);
             if (PL_endav && !PL_minus_c)
                 call_list(PL_scopestack_ix, PL_endav);
             JMPENV_POP;
         }
         LEAVE;
         FREETMPS;
  
         *interp = NULL;
     }
 }

References dTHX, PERL_UNUSED_VAR, and x.

Referenced by plperl_fini().

◆ plperl_event_trigger_build_args()

static SV* plperl_event_trigger_build_args ( FunctionCallInfo fcinfo )

static

Definition at line 1744 of file plperl.c.

 {
     dTHX;
     EventTriggerData *tdata;
     HV         *hv;
  
     hv = newHV();
  
     tdata = (EventTriggerData *) fcinfo->context;
  
     hv_store_string(hv, "event", cstr2sv(tdata->event));
     hv_store_string(hv, "tag", cstr2sv(GetCommandTagName(tdata->tag)));
  
     return newRV_noinc((SV *) hv);
 }

References FunctionCallInfoBaseData::context, cstr2sv(), dTHX, EventTriggerData::event, GetCommandTagName(), hv_store_string(), newRV_noinc, and EventTriggerData::tag.

Referenced by plperl_event_trigger_handler().

◆ plperl_event_trigger_handler()

static void plperl_event_trigger_handler ( PG_FUNCTION_ARGS )

static

Definition at line 2634 of file plperl.c.

 {
     plperl_proc_desc *prodesc;
     SV         *svTD;
     ErrorContextCallback pl_error_context;
  
     /* Connect to SPI manager */
     if (SPI_connect() != SPI_OK_CONNECT)
         elog(ERROR, "could not connect to SPI manager");
  
     /* Find or compile the function */
     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
     current_call_data->prodesc = prodesc;
     increment_prodesc_refcount(prodesc);
  
     /* Set a callback for error reporting */
     pl_error_context.callback = plperl_exec_callback;
     pl_error_context.previous = error_context_stack;
     pl_error_context.arg = prodesc->proname;
     error_context_stack = &pl_error_context;
  
     activate_interpreter(prodesc->interp);
  
     svTD = plperl_event_trigger_build_args(fcinfo);
     plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
  
     if (SPI_finish() != SPI_OK_FINISH)
         elog(ERROR, "SPI_finish() failed");
  
     /* Restore the previous error callback */
     error_context_stack = pl_error_context.previous;
  
     SvREFCNT_dec_current(svTD);
 }

References activate_interpreter(), ErrorContextCallback::arg, ErrorContextCallback::callback, compile_plperl_function(), current_call_data, elog, ERROR, error_context_stack, increment_prodesc_refcount, plperl_proc_desc::interp, plperl_call_perl_event_trigger_func(), plperl_event_trigger_build_args(), plperl_exec_callback(), ErrorContextCallback::previous, plperl_call_data::prodesc, plperl_proc_desc::proname, SPI_connect(), SPI_finish(), SPI_OK_CONNECT, SPI_OK_FINISH, and SvREFCNT_dec_current().

Referenced by plperl_call_handler().

◆ plperl_exec_callback()

static void plperl_exec_callback ( void * arg )

static

Definition at line 4143 of file plperl.c.

 {
     char       *procname = (char *) arg;
  
     if (procname)
         errcontext("PL/Perl function \"%s\"", procname);
 }

References arg, and errcontext.

Referenced by plperl_event_trigger_handler(), plperl_func_handler(), and plperl_trigger_handler().

◆ plperl_fini()

static void plperl_fini	(	int	code,
		Datum	arg
	)

static

Definition at line 509 of file plperl.c.

 {
     HASH_SEQ_STATUS hash_seq;
     plperl_interp_desc *interp_desc;
  
     elog(DEBUG3, "plperl_fini");
  
     /*
      * Indicate that perl is terminating. Disables use of spi_* functions when
      * running END/DESTROY code. See check_spi_usage_allowed(). Could be
      * enabled in future, with care, using a transaction
      * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
      */
     plperl_ending = true;
  
     /* Only perform perl cleanup if we're exiting cleanly */
     if (code)
     {
         elog(DEBUG3, "plperl_fini: skipped");
         return;
     }
  
     /* Zap the "held" interpreter, if we still have it */
     plperl_destroy_interp(&plperl_held_interp);
  
     /* Zap any fully-initialized interpreters */
     hash_seq_init(&hash_seq, plperl_interp_hash);
     while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
     {
         if (interp_desc->interp)
         {
             activate_interpreter(interp_desc);
             plperl_destroy_interp(&interp_desc->interp);
         }
     }
  
     elog(DEBUG3, "plperl_fini: done");
 }

References activate_interpreter(), DEBUG3, elog, hash_seq_init(), hash_seq_search(), plperl_interp_desc::interp, plperl_destroy_interp(), plperl_ending, plperl_held_interp, and plperl_interp_hash.

Referenced by select_perl_context().

◆ plperl_func_handler()

static Datum plperl_func_handler ( PG_FUNCTION_ARGS )

static

Definition at line 2402 of file plperl.c.

 {
     bool        nonatomic;
     plperl_proc_desc *prodesc;
     SV         *perlret;
     Datum       retval = 0;
     ReturnSetInfo *rsi;
     ErrorContextCallback pl_error_context;
  
     nonatomic = fcinfo->context &&
         IsA(fcinfo->context, CallContext) &&
         !castNode(CallContext, fcinfo->context)->atomic;
  
     if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT)
         elog(ERROR, "could not connect to SPI manager");
  
     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
     current_call_data->prodesc = prodesc;
     increment_prodesc_refcount(prodesc);
  
     /* Set a callback for error reporting */
     pl_error_context.callback = plperl_exec_callback;
     pl_error_context.previous = error_context_stack;
     pl_error_context.arg = prodesc->proname;
     error_context_stack = &pl_error_context;
  
     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
  
     if (prodesc->fn_retisset)
     {
         /* Check context before allowing the call to go through */
         if (!rsi || !IsA(rsi, ReturnSetInfo))
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("set-valued function called in context that cannot accept a set")));
  
         if (!(rsi->allowedModes & SFRM_Materialize))
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("materialize mode required, but it is not allowed in this context")));
     }
  
     activate_interpreter(prodesc->interp);
  
     perlret = plperl_call_perl_func(prodesc, fcinfo);
  
     /************************************************************
      * Disconnect from SPI manager and then create the return
      * values datum (if the input function does a palloc for it
      * this must not be allocated in the SPI memory context
      * because SPI_finish would free it).
      ************************************************************/
     if (SPI_finish() != SPI_OK_FINISH)
         elog(ERROR, "SPI_finish() failed");
  
     if (prodesc->fn_retisset)
     {
         SV         *sav;
  
         /*
          * If the Perl function returned an arrayref, we pretend that it
          * called return_next() for each element of the array, to handle old
          * SRFs that didn't know about return_next(). Any other sort of return
          * value is an error, except undef which means return an empty set.
          */
         sav = get_perl_array_ref(perlret);
         if (sav)
         {
             dTHX;
             int         i = 0;
             SV        **svp = 0;
             AV         *rav = (AV *) SvRV(sav);
  
             while ((svp = av_fetch(rav, i, FALSE)) != NULL)
             {
                 plperl_return_next_internal(*svp);
                 i++;
             }
         }
         else if (SvOK(perlret))
         {
             ereport(ERROR,
                     (errcode(ERRCODE_DATATYPE_MISMATCH),
                      errmsg("set-returning PL/Perl function must return "
                             "reference to array or use return_next")));
         }
  
         rsi->returnMode = SFRM_Materialize;
         if (current_call_data->tuple_store)
         {
             rsi->setResult = current_call_data->tuple_store;
             rsi->setDesc = current_call_data->ret_tdesc;
         }
         retval = (Datum) 0;
     }
     else if (prodesc->result_oid)
     {
         retval = plperl_sv_to_datum(perlret,
                                     prodesc->result_oid,
                                     -1,
                                     fcinfo,
                                     &prodesc->result_in_func,
                                     prodesc->result_typioparam,
                                     &fcinfo->isnull);
  
         if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
             rsi->isDone = ExprEndResult;
     }
  
     /* Restore the previous error callback */
     error_context_stack = pl_error_context.previous;
  
     SvREFCNT_dec_current(perlret);
  
     return retval;
 }

References activate_interpreter(), ReturnSetInfo::allowedModes, ErrorContextCallback::arg, ErrorContextCallback::callback, castNode, compile_plperl_function(), current_call_data, dTHX, elog, ereport, errcode(), errmsg(), ERROR, error_context_stack, ExprEndResult, plperl_proc_desc::fn_retisset, get_perl_array_ref(), i, if(), increment_prodesc_refcount, plperl_proc_desc::interp, IsA, ReturnSetInfo::isDone, plperl_call_perl_func(), plperl_exec_callback(), plperl_return_next_internal(), plperl_sv_to_datum(), ErrorContextCallback::previous, plperl_call_data::prodesc, plperl_proc_desc::proname, plperl_proc_desc::result_in_func, plperl_proc_desc::result_oid, plperl_proc_desc::result_typioparam, plperl_call_data::ret_tdesc, ReturnSetInfo::returnMode, ReturnSetInfo::setDesc, ReturnSetInfo::setResult, SFRM_Materialize, SPI_connect_ext(), SPI_finish(), SPI_OK_CONNECT, SPI_OK_FINISH, SPI_OPT_NONATOMIC, SvREFCNT_dec_current(), and plperl_call_data::tuple_store.

Referenced by plperl_call_handler().

◆ plperl_hash_from_datum()

static SV * plperl_hash_from_datum ( Datum attr )

static

Definition at line 2998 of file plperl.c.

 {
     HeapTupleHeader td;
     Oid         tupType;
     int32       tupTypmod;
     TupleDesc   tupdesc;
     HeapTupleData tmptup;
     SV         *sv;
  
     td = DatumGetHeapTupleHeader(attr);
  
     /* Extract rowtype info and find a tupdesc */
     tupType = HeapTupleHeaderGetTypeId(td);
     tupTypmod = HeapTupleHeaderGetTypMod(td);
     tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
  
     /* Build a temporary HeapTuple control structure */
     tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
     tmptup.t_data = td;
  
     sv = plperl_hash_from_tuple(&tmptup, tupdesc, true);
     ReleaseTupleDesc(tupdesc);
  
     return sv;
 }

References DatumGetHeapTupleHeader, HeapTupleHeaderGetDatumLength, HeapTupleHeaderGetTypeId, HeapTupleHeaderGetTypMod, lookup_rowtype_tupdesc(), plperl_hash_from_tuple(), ReleaseTupleDesc, HeapTupleData::t_data, and HeapTupleData::t_len.

Referenced by make_array_ref(), plperl_call_perl_func(), and plperl_hash_from_tuple().

◆ plperl_hash_from_tuple()

static SV * plperl_hash_from_tuple	(	HeapTuple	tuple,
		TupleDesc	tupdesc,
		bool	include_generated
	)

static

Definition at line 3026 of file plperl.c.

 {
     dTHX;
     HV         *hv;
     int         i;
  
     /* since this function recurses, it could be driven to stack overflow */
     check_stack_depth();
  
     hv = newHV();
     hv_ksplit(hv, tupdesc->natts);  /* pre-grow the hash */
  
     for (i = 0; i < tupdesc->natts; i++)
     {
         Datum       attr;
         bool        isnull,
                     typisvarlena;
         char       *attname;
         Oid         typoutput;
         Form_pg_attribute att = TupleDescAttr(tupdesc, i);
  
         if (att->attisdropped)
             continue;
  
         if (att->attgenerated)
         {
             /* don't include unless requested */
             if (!include_generated)
                 continue;
         }
  
         attname = NameStr(att->attname);
         attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
  
         if (isnull)
         {
             /*
              * Store (attname => undef) and move on.  Note we can't use
              * &PL_sv_undef here; see "AVs, HVs and undefined values" in
              * perlguts for an explanation.
              */
             hv_store_string(hv, attname, newSV(0));
             continue;
         }
  
         if (type_is_rowtype(att->atttypid))
         {
             SV         *sv = plperl_hash_from_datum(attr);
  
             hv_store_string(hv, attname, sv);
         }
         else
         {
             SV         *sv;
             Oid         funcid;
  
             if (OidIsValid(get_base_element_type(att->atttypid)))
                 sv = plperl_ref_from_pg_array(attr, att->atttypid);
             else if ((funcid = get_transform_fromsql(att->atttypid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
                 sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr));
             else
             {
                 char       *outputstr;
  
                 /* XXX should have a way to cache these lookups */
                 getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
  
                 outputstr = OidOutputFunctionCall(typoutput, attr);
                 sv = cstr2sv(outputstr);
                 pfree(outputstr);
             }
  
             hv_store_string(hv, attname, sv);
         }
     }
     return newRV_noinc((SV *) hv);
 }

References attname, check_stack_depth(), cstr2sv(), current_call_data, DatumGetPointer(), dTHX, get_base_element_type(), get_transform_fromsql(), getTypeOutputInfo(), heap_getattr(), hv_store_string(), i, plperl_proc_desc::lang_oid, NameStr, TupleDescData::natts, newRV_noinc, OidFunctionCall1, OidIsValid, OidOutputFunctionCall(), pfree(), plperl_hash_from_datum(), plperl_ref_from_pg_array(), plperl_call_data::prodesc, plperl_proc_desc::trftypes, TupleDescAttr, and type_is_rowtype().

Referenced by plperl_hash_from_datum(), plperl_spi_execute_fetch_result(), plperl_spi_fetchrow(), and plperl_trigger_build_args().

◆ plperl_hash_to_datum()

static Datum plperl_hash_to_datum	(	SV *	src,
		TupleDesc	td
	)

static

Definition at line 1126 of file plperl.c.

 {
     HeapTuple   tup = plperl_build_tuple_result((HV *) SvRV(src), td);
  
     return HeapTupleGetDatum(tup);
 }

References HeapTupleGetDatum(), and plperl_build_tuple_result().

Referenced by plperl_sv_to_datum().

◆ plperl_init_interp()

static PerlInterpreter * plperl_init_interp ( void )

static

Definition at line 705 of file plperl.c.

 {
     PerlInterpreter *plperl;
  
     static char *embedding[3 + 2] = {
         "", "-e", PLC_PERLBOOT
     };
     int         nargs = 3;
  
 #ifdef WIN32
  
     /*
      * The perl library on startup does horrible things like call
      * setlocale(LC_ALL,""). We have protected against that on most platforms
      * by setting the environment appropriately. However, on Windows,
      * setlocale() does not consult the environment, so we need to save the
      * existing locale settings before perl has a chance to mangle them and
      * restore them after its dirty deeds are done.
      *
      * MSDN ref:
      * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
      *
      * It appears that we only need to do this on interpreter startup, and
      * subsequent calls to the interpreter don't mess with the locale
      * settings.
      *
      * We restore them using setlocale_perl(), defined below, so that Perl
      * doesn't have a different idea of the locale from Postgres.
      *
      */
  
     char       *loc;
     char       *save_collate,
                *save_ctype,
                *save_monetary,
                *save_numeric,
                *save_time;
  
     loc = setlocale(LC_COLLATE, NULL);
     save_collate = loc ? pstrdup(loc) : NULL;
     loc = setlocale(LC_CTYPE, NULL);
     save_ctype = loc ? pstrdup(loc) : NULL;
     loc = setlocale(LC_MONETARY, NULL);
     save_monetary = loc ? pstrdup(loc) : NULL;
     loc = setlocale(LC_NUMERIC, NULL);
     save_numeric = loc ? pstrdup(loc) : NULL;
     loc = setlocale(LC_TIME, NULL);
     save_time = loc ? pstrdup(loc) : NULL;
  
 #define PLPERL_RESTORE_LOCALE(name, saved) \
     STMT_START { \
         if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
     } STMT_END
 #endif                          /* WIN32 */
  
     if (plperl_on_init && *plperl_on_init)
     {
         embedding[nargs++] = "-e";
         embedding[nargs++] = plperl_on_init;
     }
  
     /*
      * The perl API docs state that PERL_SYS_INIT3 should be called before
      * allocating interpreters. Unfortunately, on some platforms this fails in
      * the Perl_do_taint() routine, which is called when the platform is using
      * the system's malloc() instead of perl's own. Other platforms, notably
      * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
      * available, unless perl is using the system malloc(), which is true when
      * MYMALLOC is set.
      */
 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
     {
         static int  perl_sys_init_done;
  
         /* only call this the first time through, as per perlembed man page */
         if (!perl_sys_init_done)
         {
             char       *dummy_env[1] = {NULL};
  
             PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
  
             /*
              * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to
              * SIG_IGN.  Aside from being extremely unfriendly behavior for a
              * library, this is dumb on the grounds that the results of a
              * SIGFPE in this state are undefined according to POSIX, and in
              * fact you get a forced process kill at least on Linux.  Hence,
              * restore the SIGFPE handler to the backend's standard setting.
              * (See Perl bug 114574 for more information.)
              */
             pqsignal(SIGFPE, FloatExceptionHandler);
  
             perl_sys_init_done = 1;
             /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
             dummy_env[0] = NULL;
         }
     }
 #endif
  
     plperl = perl_alloc();
     if (!plperl)
         elog(ERROR, "could not allocate Perl interpreter");
  
     PERL_SET_CONTEXT(plperl);
     perl_construct(plperl);
  
     /*
      * Run END blocks in perl_destruct instead of perl_run.  Note that dTHX
      * loads up a pointer to the current interpreter, so we have to postpone
      * it to here rather than put it at the function head.
      */
     {
         dTHX;
  
         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
  
         /*
          * Record the original function for the 'require' and 'dofile'
          * opcodes.  (They share the same implementation.)  Ensure it's used
          * for new interpreters.
          */
         if (!pp_require_orig)
             pp_require_orig = PL_ppaddr[OP_REQUIRE];
         else
         {
             PL_ppaddr[OP_REQUIRE] = pp_require_orig;
             PL_ppaddr[OP_DOFILE] = pp_require_orig;
         }
  
 #ifdef PLPERL_ENABLE_OPMASK_EARLY
  
         /*
          * For regression testing to prove that the PLC_PERLBOOT and
          * PLC_TRUSTED code doesn't even compile any unsafe ops.  In future
          * there may be a valid need for them to do so, in which case this
          * could be softened (perhaps moved to plperl_trusted_init()) or
          * removed.
          */
         PL_op_mask = plperl_opmask;
 #endif
  
         if (perl_parse(plperl, plperl_init_shared_libs,
                        nargs, embedding, NULL) != 0)
             ereport(ERROR,
                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                      errcontext("while parsing Perl initialization")));
  
         if (perl_run(plperl) != 0)
             ereport(ERROR,
                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                      errcontext("while running Perl initialization")));
  
 #ifdef PLPERL_RESTORE_LOCALE
         PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
         PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
         PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
         PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
         PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
 #endif
     }
  
     return plperl;
 }

References dTHX, elog, ereport, errcode(), errcontext, errmsg(), ERROR, ERRSV, FloatExceptionHandler(), PL_ppaddr, plperl_init_shared_libs(), plperl_on_init, plperl_opmask, pp_require_orig, pqsignal(), pstrdup(), setlocale, strip_trailing_ws(), and sv2cstr().

Referenced by _PG_init(), and select_perl_context().

◆ plperl_init_shared_libs()

static void plperl_init_shared_libs ( pTHX )

static

Definition at line 2168 of file plperl.c.

 {
     char       *file = __FILE__;
  
     newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
     newXS("PostgreSQL::InServer::Util::bootstrap",
           boot_PostgreSQL__InServer__Util, file);
     /* newXS for...::SPI::bootstrap is in select_perl_context() */
 }

References boot_DynaLoader(), and boot_PostgreSQL__InServer__Util().

Referenced by plperl_init_interp().

◆ plperl_inline_callback()

static void plperl_inline_callback ( void * arg )

static

Definition at line 4167 of file plperl.c.

 {
     errcontext("PL/Perl anonymous code block");
 }

References errcontext.

Referenced by plperl_inline_handler().

◆ plperl_inline_handler()

Datum plperl_inline_handler ( PG_FUNCTION_ARGS )

Definition at line 1894 of file plperl.c.

 {
     LOCAL_FCINFO(fake_fcinfo, 0);
     InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
     FmgrInfo    flinfo;
     plperl_proc_desc desc;
     plperl_call_data *volatile save_call_data = current_call_data;
     plperl_interp_desc *volatile oldinterp = plperl_active_interp;
     plperl_call_data this_call_data;
     ErrorContextCallback pl_error_context;
  
     /* Initialize current-call status record */
     MemSet(&this_call_data, 0, sizeof(this_call_data));
  
     /* Set up a callback for error reporting */
     pl_error_context.callback = plperl_inline_callback;
     pl_error_context.previous = error_context_stack;
     pl_error_context.arg = NULL;
     error_context_stack = &pl_error_context;
  
     /*
      * Set up a fake fcinfo and descriptor with just enough info to satisfy
      * plperl_call_perl_func().  In particular note that this sets things up
      * with no arguments passed, and a result type of VOID.
      */
     MemSet(fake_fcinfo, 0, SizeForFunctionCallInfo(0));
     MemSet(&flinfo, 0, sizeof(flinfo));
     MemSet(&desc, 0, sizeof(desc));
     fake_fcinfo->flinfo = &flinfo;
     flinfo.fn_oid = InvalidOid;
     flinfo.fn_mcxt = CurrentMemoryContext;
  
     desc.proname = "inline_code_block";
     desc.fn_readonly = false;
  
     desc.lang_oid = codeblock->langOid;
     desc.trftypes = NIL;
     desc.lanpltrusted = codeblock->langIsTrusted;
  
     desc.fn_retistuple = false;
     desc.fn_retisset = false;
     desc.fn_retisarray = false;
     desc.result_oid = InvalidOid;
     desc.nargs = 0;
     desc.reference = NULL;
  
     this_call_data.fcinfo = fake_fcinfo;
     this_call_data.prodesc = &desc;
     /* we do not bother with refcounting the fake prodesc */
  
     PG_TRY();
     {
         SV         *perlret;
  
         current_call_data = &this_call_data;
  
         if (SPI_connect_ext(codeblock->atomic ? 0 : SPI_OPT_NONATOMIC) != SPI_OK_CONNECT)
             elog(ERROR, "could not connect to SPI manager");
  
         select_perl_context(desc.lanpltrusted);
  
         plperl_create_sub(&desc, codeblock->source_text, 0);
  
         if (!desc.reference)    /* can this happen? */
             elog(ERROR, "could not create internal procedure for anonymous code block");
  
         perlret = plperl_call_perl_func(&desc, fake_fcinfo);
  
         SvREFCNT_dec_current(perlret);
  
         if (SPI_finish() != SPI_OK_FINISH)
             elog(ERROR, "SPI_finish() failed");
     }
     PG_FINALLY();
     {
         if (desc.reference)
             SvREFCNT_dec_current(desc.reference);
         current_call_data = save_call_data;
         activate_interpreter(oldinterp);
     }
     PG_END_TRY();
  
     error_context_stack = pl_error_context.previous;
  
     PG_RETURN_VOID();
 }

Referenced by plperlu_inline_handler().

◆ plperl_modify_tuple()

static HeapTuple plperl_modify_tuple	(	HV *	hvTD,
		TriggerData *	tdata,
		HeapTuple	otup
	)

static

Definition at line 1762 of file plperl.c.

 {
     dTHX;
     SV        **svp;
     HV         *hvNew;
     HE         *he;
     HeapTuple   rtup;
     TupleDesc   tupdesc;
     int         natts;
     Datum      *modvalues;
     bool       *modnulls;
     bool       *modrepls;
  
     svp = hv_fetch_string(hvTD, "new");
     if (!svp)
         ereport(ERROR,
                 (errcode(ERRCODE_UNDEFINED_COLUMN),
                  errmsg("$_TD->{new} does not exist")));
     if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
         ereport(ERROR,
                 (errcode(ERRCODE_DATATYPE_MISMATCH),
                  errmsg("$_TD->{new} is not a hash reference")));
     hvNew = (HV *) SvRV(*svp);
  
     tupdesc = tdata->tg_relation->rd_att;
     natts = tupdesc->natts;
  
     modvalues = (Datum *) palloc0(natts * sizeof(Datum));
     modnulls = (bool *) palloc0(natts * sizeof(bool));
     modrepls = (bool *) palloc0(natts * sizeof(bool));
  
     hv_iterinit(hvNew);
     while ((he = hv_iternext(hvNew)))
     {
         char       *key = hek2cstr(he);
         SV         *val = HeVAL(he);
         int         attn = SPI_fnumber(tupdesc, key);
         Form_pg_attribute attr = TupleDescAttr(tupdesc, attn - 1);
  
         if (attn == SPI_ERROR_NOATTRIBUTE)
             ereport(ERROR,
                     (errcode(ERRCODE_UNDEFINED_COLUMN),
                      errmsg("Perl hash contains nonexistent column \"%s\"",
                             key)));
         if (attn <= 0)
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("cannot set system attribute \"%s\"",
                             key)));
         if (attr->attgenerated)
             ereport(ERROR,
                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
                      errmsg("cannot set generated column \"%s\"",
                             key)));
  
         modvalues[attn - 1] = plperl_sv_to_datum(val,
                                                  attr->atttypid,
                                                  attr->atttypmod,
                                                  NULL,
                                                  NULL,
                                                  InvalidOid,
                                                  &modnulls[attn - 1]);
         modrepls[attn - 1] = true;
  
         pfree(key);
     }
     hv_iterinit(hvNew);
  
     rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls);
  
     pfree(modvalues);
     pfree(modnulls);
     pfree(modrepls);
  
     return rtup;
 }

References dTHX, ereport, errcode(), errmsg(), ERROR, heap_modify_tuple(), hek2cstr(), hv_fetch_string(), InvalidOid, sort-test::key, TupleDescData::natts, palloc0(), pfree(), plperl_sv_to_datum(), RelationData::rd_att, SPI_ERROR_NOATTRIBUTE, SPI_fnumber(), TriggerData::tg_relation, TupleDescAttr, and val.

Referenced by plperl_trigger_handler().

◆ plperl_ref_from_pg_array()

static SV * plperl_ref_from_pg_array	(	Datum	arg,
		Oid	typid
	)

static

Definition at line 1480 of file plperl.c.

 {
     dTHX;
     ArrayType  *ar = DatumGetArrayTypeP(arg);
     Oid         elementtype = ARR_ELEMTYPE(ar);
     int16       typlen;
     bool        typbyval;
     char        typalign,
                 typdelim;
     Oid         typioparam;
     Oid         typoutputfunc;
     Oid         transform_funcid;
     int         i,
                 nitems,
                *dims;
     plperl_array_info *info;
     SV         *av;
     HV         *hv;
  
     /*
      * Currently we make no effort to cache any of the stuff we look up here,
      * which is bad.
      */
     info = palloc0(sizeof(plperl_array_info));
  
     /* get element type information, including output conversion function */
     get_type_io_data(elementtype, IOFunc_output,
                      &typlen, &typbyval, &typalign,
                      &typdelim, &typioparam, &typoutputfunc);
  
     /* Check for a transform function */
     transform_funcid = get_transform_fromsql(elementtype,
                                              current_call_data->prodesc->lang_oid,
                                              current_call_data->prodesc->trftypes);
  
     /* Look up transform or output function as appropriate */
     if (OidIsValid(transform_funcid))
         fmgr_info(transform_funcid, &info->transform_proc);
     else
         fmgr_info(typoutputfunc, &info->proc);
  
     info->elem_is_rowtype = type_is_rowtype(elementtype);
  
     /* Get the number and bounds of array dimensions */
     info->ndims = ARR_NDIM(ar);
     dims = ARR_DIMS(ar);
  
     /* No dimensions? Return an empty array */
     if (info->ndims == 0)
     {
         av = newRV_noinc((SV *) newAV());
     }
     else
     {
         deconstruct_array(ar, elementtype, typlen, typbyval,
                           typalign, &info->elements, &info->nulls,
                           &nitems);
  
         /* Get total number of elements in each dimension */
         info->nelems = palloc(sizeof(int) * info->ndims);
         info->nelems[0] = nitems;
         for (i = 1; i < info->ndims; i++)
             info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
  
         av = split_array(info, 0, nitems, 0);
     }
  
     hv = newHV();
     (void) hv_store(hv, "array", 5, av, 0);
     (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0);
  
     return sv_bless(newRV_noinc((SV *) hv),
                     gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
 }

References arg, ARR_DIMS, ARR_ELEMTYPE, ARR_NDIM, av, current_call_data, DatumGetArrayTypeP, deconstruct_array(), dTHX, plperl_array_info::elem_is_rowtype, plperl_array_info::elements, fmgr_info(), get_transform_fromsql(), get_type_io_data(), i, IOFunc_output, plperl_proc_desc::lang_oid, plperl_array_info::ndims, plperl_array_info::nelems, newRV_noinc, newSVuv, nitems, plperl_array_info::nulls, OidIsValid, palloc(), palloc0(), plperl_array_info::proc, plperl_call_data::prodesc, split_array(), plperl_array_info::transform_proc, plperl_proc_desc::trftypes, typalign, and type_is_rowtype().

Referenced by plperl_call_perl_func(), and plperl_hash_from_tuple().

◆ plperl_return_next()

void plperl_return_next ( SV * sv )

Definition at line 3245 of file plperl.c.

 {
     MemoryContext oldcontext = CurrentMemoryContext;
  
     check_spi_usage_allowed();
  
     PG_TRY();
     {
         plperl_return_next_internal(sv);
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Must reset elog.c's state */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
     }
     PG_END_TRY();
 }

References check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), CurrentMemoryContext, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, PG_CATCH, PG_END_TRY, PG_TRY, and plperl_return_next_internal().

◆ plperl_return_next_internal()

static void plperl_return_next_internal ( SV * sv )

static

Definition at line 3275 of file plperl.c.

 {
     plperl_proc_desc *prodesc;
     FunctionCallInfo fcinfo;
     ReturnSetInfo *rsi;
     MemoryContext old_cxt;
  
     if (!sv)
         return;
  
     prodesc = current_call_data->prodesc;
     fcinfo = current_call_data->fcinfo;
     rsi = (ReturnSetInfo *) fcinfo->resultinfo;
  
     if (!prodesc->fn_retisset)
         ereport(ERROR,
                 (errcode(ERRCODE_SYNTAX_ERROR),
                  errmsg("cannot use return_next in a non-SETOF function")));
  
     if (!current_call_data->ret_tdesc)
     {
         TupleDesc   tupdesc;
  
         Assert(!current_call_data->tuple_store);
  
         /*
          * This is the first call to return_next in the current PL/Perl
          * function call, so identify the output tuple type and create a
          * tuplestore to hold the result rows.
          */
         if (prodesc->fn_retistuple)
         {
             TypeFuncClass funcclass;
             Oid         typid;
  
             funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
             if (funcclass != TYPEFUNC_COMPOSITE &&
                 funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
                 ereport(ERROR,
                         (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                          errmsg("function returning record called in context "
                                 "that cannot accept type record")));
             /* if domain-over-composite, remember the domain's type OID */
             if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
                 current_call_data->cdomain_oid = typid;
         }
         else
         {
             tupdesc = rsi->expectedDesc;
             /* Protect assumption below that we return exactly one column */
             if (tupdesc == NULL || tupdesc->natts != 1)
                 elog(ERROR, "expected single-column result descriptor for non-composite SETOF result");
         }
  
         /*
          * Make sure the tuple_store and ret_tdesc are sufficiently
          * long-lived.
          */
         old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
  
         current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
         current_call_data->tuple_store =
             tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random,
                                   false, work_mem);
  
         MemoryContextSwitchTo(old_cxt);
     }
  
     /*
      * Producing the tuple we want to return requires making plenty of
      * palloc() allocations that are not cleaned up. Since this function can
      * be called many times before the current memory context is reset, we
      * need to do those allocations in a temporary context.
      */
     if (!current_call_data->tmp_cxt)
     {
         current_call_data->tmp_cxt =
             AllocSetContextCreate(CurrentMemoryContext,
                                   "PL/Perl return_next temporary cxt",
                                   ALLOCSET_DEFAULT_SIZES);
     }
  
     old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
  
     if (prodesc->fn_retistuple)
     {
         HeapTuple   tuple;
  
         if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
             ereport(ERROR,
                     (errcode(ERRCODE_DATATYPE_MISMATCH),
                      errmsg("SETOF-composite-returning PL/Perl function "
                             "must call return_next with reference to hash")));
  
         tuple = plperl_build_tuple_result((HV *) SvRV(sv),
                                           current_call_data->ret_tdesc);
  
         if (OidIsValid(current_call_data->cdomain_oid))
             domain_check(HeapTupleGetDatum(tuple), false,
                          current_call_data->cdomain_oid,
                          &current_call_data->cdomain_info,
                          rsi->econtext->ecxt_per_query_memory);
  
         tuplestore_puttuple(current_call_data->tuple_store, tuple);
     }
     else if (prodesc->result_oid)
     {
         Datum       ret[1];
         bool        isNull[1];
  
         ret[0] = plperl_sv_to_datum(sv,
                                     prodesc->result_oid,
                                     -1,
                                     fcinfo,
                                     &prodesc->result_in_func,
                                     prodesc->result_typioparam,
                                     &isNull[0]);
  
         tuplestore_putvalues(current_call_data->tuple_store,
                              current_call_data->ret_tdesc,
                              ret, isNull);
     }
  
     MemoryContextSwitchTo(old_cxt);
     MemoryContextReset(current_call_data->tmp_cxt);
 }

References ALLOCSET_DEFAULT_SIZES, AllocSetContextCreate, ReturnSetInfo::allowedModes, Assert, plperl_call_data::cdomain_info, plperl_call_data::cdomain_oid, CreateTupleDescCopy(), current_call_data, CurrentMemoryContext, domain_check(), ReturnSetInfo::econtext, ExprContext::ecxt_per_query_memory, elog, ereport, errcode(), errmsg(), ERROR, ReturnSetInfo::expectedDesc, plperl_call_data::fcinfo, plperl_proc_desc::fn_retisset, plperl_proc_desc::fn_retistuple, get_call_result_type(), HeapTupleGetDatum(), if(), MemoryContextReset(), MemoryContextSwitchTo(), TupleDescData::natts, OidIsValid, plperl_build_tuple_result(), plperl_sv_to_datum(), plperl_call_data::prodesc, plperl_proc_desc::result_in_func, plperl_proc_desc::result_oid, plperl_proc_desc::result_typioparam, FunctionCallInfoBaseData::resultinfo, plperl_call_data::ret_tdesc, SFRM_Materialize_Random, plperl_call_data::tmp_cxt, plperl_call_data::tuple_store, tuplestore_begin_heap(), tuplestore_puttuple(), tuplestore_putvalues(), TYPEFUNC_COMPOSITE, TYPEFUNC_COMPOSITE_DOMAIN, and work_mem.

Referenced by plperl_func_handler(), and plperl_return_next().

◆ plperl_spi_commit()

void plperl_spi_commit ( void )

Definition at line 3991 of file plperl.c.

 {
     MemoryContext oldcontext = CurrentMemoryContext;
  
     check_spi_usage_allowed();
  
     PG_TRY();
     {
         SPI_commit();
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
     }
     PG_END_TRY();
 }

References check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), CurrentMemoryContext, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, PG_CATCH, PG_END_TRY, PG_TRY, and SPI_commit().

◆ plperl_spi_cursor_close()

void plperl_spi_cursor_close ( char * cursor )

Definition at line 3551 of file plperl.c.

 {
     Portal      p;
  
     check_spi_usage_allowed();
  
     p = SPI_cursor_find(cursor);
  
     if (p)
     {
         UnpinPortal(p);
         SPI_cursor_close(p);
     }
 }

References check_spi_usage_allowed(), SPI_cursor_close(), SPI_cursor_find(), and UnpinPortal().

◆ plperl_spi_exec()

HV* plperl_spi_exec	(	char *	query,
		int	limit
	)

Definition at line 3133 of file plperl.c.

 {
     HV         *ret_hv;
  
     /*
      * Execute the query inside a sub-transaction, so we can cope with errors
      * sanely
      */
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     /* Want to run inside function's memory context */
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         int         spi_rv;
  
         pg_verifymbstr(query, strlen(query), false);
  
         spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
                              limit);
         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
                                                  spi_rv);
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     return ret_hv;
 }

References BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), current_call_data, CurrentMemoryContext, CurrentResourceOwner, FlushErrorState(), plperl_proc_desc::fn_readonly, MemoryContextSwitchTo(), ErrorData::message, PG_CATCH, PG_END_TRY, PG_TRY, pg_verifymbstr(), plperl_spi_execute_fetch_result(), plperl_call_data::prodesc, ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_execute(), SPI_processed, and SPI_tuptable.

◆ plperl_spi_exec_prepared()

HV* plperl_spi_exec_prepared	(	char *	query,
		HV *	attr,
		int	argc,
		SV **	argv
	)

Definition at line 3715 of file plperl.c.

 {
     HV         *ret_hv;
     SV        **sv;
     int         i,
                 limit,
                 spi_rv;
     char       *nulls;
     Datum      *argvalues;
     plperl_query_desc *qdesc;
     plperl_query_entry *hash_entry;
  
     /*
      * Execute the query inside a sub-transaction, so we can cope with errors
      * sanely
      */
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     /* Want to run inside function's memory context */
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         dTHX;
  
         /************************************************************
          * Fetch the saved plan descriptor, see if it's o.k.
          ************************************************************/
         hash_entry = hash_search(plperl_active_interp->query_hash, query,
                                  HASH_FIND, NULL);
         if (hash_entry == NULL)
             elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
  
         qdesc = hash_entry->query_data;
         if (qdesc == NULL)
             elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished");
  
         if (qdesc->nargs != argc)
             elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
                  qdesc->nargs, argc);
  
         /************************************************************
          * Parse eventual attributes
          ************************************************************/
         limit = 0;
         if (attr != NULL)
         {
             sv = hv_fetch_string(attr, "limit");
             if (sv && *sv && SvIOK(*sv))
                 limit = SvIV(*sv);
         }
         /************************************************************
          * Set up arguments
          ************************************************************/
         if (argc > 0)
         {
             nulls = (char *) palloc(argc);
             argvalues = (Datum *) palloc(argc * sizeof(Datum));
         }
         else
         {
             nulls = NULL;
             argvalues = NULL;
         }
  
         for (i = 0; i < argc; i++)
         {
             bool        isnull;
  
             argvalues[i] = plperl_sv_to_datum(argv[i],
                                               qdesc->argtypes[i],
                                               -1,
                                               NULL,
                                               &qdesc->arginfuncs[i],
                                               qdesc->argtypioparams[i],
                                               &isnull);
             nulls[i] = isnull ? 'n' : ' ';
         }
  
         /************************************************************
          * go
          ************************************************************/
         spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
                                   current_call_data->prodesc->fn_readonly, limit);
         ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
                                                  spi_rv);
         if (argc > 0)
         {
             pfree(argvalues);
             pfree(nulls);
         }
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     return ret_hv;
 }

References plperl_query_desc::arginfuncs, plperl_query_desc::argtypes, plperl_query_desc::argtypioparams, BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), current_call_data, CurrentMemoryContext, CurrentResourceOwner, dTHX, elog, ERROR, FlushErrorState(), plperl_proc_desc::fn_readonly, HASH_FIND, hash_search(), hv_fetch_string(), i, MemoryContextSwitchTo(), ErrorData::message, plperl_query_desc::nargs, palloc(), pfree(), PG_CATCH, PG_END_TRY, PG_TRY, plperl_query_desc::plan, plperl_active_interp, plperl_spi_execute_fetch_result(), plperl_sv_to_datum(), plperl_call_data::prodesc, plperl_query_entry::query_data, plperl_interp_desc::query_hash, ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_execute_plan(), SPI_processed, and SPI_tuptable.

◆ plperl_spi_execute_fetch_result()

static HV * plperl_spi_execute_fetch_result	(	SPITupleTable *	tuptable,
		uint64	processed,
		int	status
	)

static

Definition at line 3193 of file plperl.c.

 {
     dTHX;
     HV         *result;
  
     check_spi_usage_allowed();
  
     result = newHV();
  
     hv_store_string(result, "status",
                     cstr2sv(SPI_result_code_string(status)));
     hv_store_string(result, "processed",
                     (processed > (uint64) UV_MAX) ?
                     newSVnv((NV) processed) :
                     newSVuv((UV) processed));
  
     if (status > 0 && tuptable)
     {
         AV         *rows;
         SV         *row;
         uint64      i;
  
         /* Prevent overflow in call to av_extend() */
         if (processed > (uint64) AV_SIZE_MAX)
             ereport(ERROR,
                     (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
                      errmsg("query result has too many rows to fit in a Perl array")));
  
         rows = newAV();
         av_extend(rows, processed);
         for (i = 0; i < processed; i++)
         {
             row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc, true);
             av_push(rows, row);
         }
         hv_store_string(result, "rows",
                         newRV_noinc((SV *) rows));
     }
  
     SPI_freetuptable(tuptable);
  
     return result;
 }

References AV_SIZE_MAX, check_spi_usage_allowed(), cstr2sv(), dTHX, ereport, errcode(), errmsg(), ERROR, hv_store_string(), i, newRV_noinc, newSVuv, plperl_hash_from_tuple(), SPI_freetuptable(), SPI_result_code_string(), SPITupleTable::tupdesc, UV_MAX, and SPITupleTable::vals.

Referenced by plperl_spi_exec(), and plperl_spi_exec_prepared().

◆ plperl_spi_fetchrow()

SV* plperl_spi_fetchrow ( char * cursor )

Definition at line 3476 of file plperl.c.

 {
     SV         *row;
  
     /*
      * Execute the FETCH inside a sub-transaction, so we can cope with errors
      * sanely
      */
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     /* Want to run inside function's memory context */
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         dTHX;
         Portal      p = SPI_cursor_find(cursor);
  
         if (!p)
         {
             row = &PL_sv_undef;
         }
         else
         {
             SPI_cursor_fetch(p, true, 1);
             if (SPI_processed == 0)
             {
                 UnpinPortal(p);
                 SPI_cursor_close(p);
                 row = &PL_sv_undef;
             }
             else
             {
                 row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
                                              SPI_tuptable->tupdesc,
                                              true);
             }
             SPI_freetuptable(SPI_tuptable);
         }
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     return row;
 }

References BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), CurrentMemoryContext, CurrentResourceOwner, dTHX, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, PG_CATCH, PG_END_TRY, PG_TRY, PL_sv_undef, plperl_hash_from_tuple(), ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_cursor_close(), SPI_cursor_fetch(), SPI_cursor_find(), SPI_freetuptable(), SPI_processed, SPI_tuptable, SPITupleTable::tupdesc, UnpinPortal(), and SPITupleTable::vals.

◆ plperl_spi_freeplan()

void plperl_spi_freeplan ( char * query )

Definition at line 3960 of file plperl.c.

 {
     SPIPlanPtr  plan;
     plperl_query_desc *qdesc;
     plperl_query_entry *hash_entry;
  
     check_spi_usage_allowed();
  
     hash_entry = hash_search(plperl_active_interp->query_hash, query,
                              HASH_FIND, NULL);
     if (hash_entry == NULL)
         elog(ERROR, "spi_freeplan: Invalid prepared query passed");
  
     qdesc = hash_entry->query_data;
     if (qdesc == NULL)
         elog(ERROR, "spi_freeplan: plperl query_hash value vanished");
     plan = qdesc->plan;
  
     /*
      * free all memory before SPI_freeplan, so if it dies, nothing will be
      * left over
      */
     hash_search(plperl_active_interp->query_hash, query,
                 HASH_REMOVE, NULL);
  
     MemoryContextDelete(qdesc->plan_cxt);
  
     SPI_freeplan(plan);
 }

References check_spi_usage_allowed(), elog, ERROR, HASH_FIND, HASH_REMOVE, hash_search(), MemoryContextDelete(), plperl_query_desc::plan, plan, plperl_query_desc::plan_cxt, plperl_active_interp, plperl_query_entry::query_data, plperl_interp_desc::query_hash, and SPI_freeplan().

◆ plperl_spi_prepare()

SV* plperl_spi_prepare	(	char *	query,
		int	argc,
		SV **	argv
	)

Definition at line 3567 of file plperl.c.

 {
     volatile SPIPlanPtr plan = NULL;
     volatile MemoryContext plan_cxt = NULL;
     plperl_query_desc *volatile qdesc = NULL;
     plperl_query_entry *volatile hash_entry = NULL;
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
     MemoryContext work_cxt;
     bool        found;
     int         i;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         CHECK_FOR_INTERRUPTS();
  
         /************************************************************
          * Allocate the new querydesc structure
          *
          * The qdesc struct, as well as all its subsidiary data, lives in its
          * plan_cxt.  But note that the SPIPlan does not.
          ************************************************************/
         plan_cxt = AllocSetContextCreate(TopMemoryContext,
                                          "PL/Perl spi_prepare query",
                                          ALLOCSET_SMALL_SIZES);
         MemoryContextSwitchTo(plan_cxt);
         qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc));
         snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
         qdesc->plan_cxt = plan_cxt;
         qdesc->nargs = argc;
         qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid));
         qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo));
         qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid));
         MemoryContextSwitchTo(oldcontext);
  
         /************************************************************
          * Do the following work in a short-lived context so that we don't
          * leak a lot of memory in the PL/Perl function's SPI Proc context.
          ************************************************************/
         work_cxt = AllocSetContextCreate(CurrentMemoryContext,
                                          "PL/Perl spi_prepare workspace",
                                          ALLOCSET_DEFAULT_SIZES);
         MemoryContextSwitchTo(work_cxt);
  
         /************************************************************
          * Resolve argument type names and then look them up by oid
          * in the system cache, and remember the required information
          * for input conversion.
          ************************************************************/
         for (i = 0; i < argc; i++)
         {
             Oid         typId,
                         typInput,
                         typIOParam;
             int32       typmod;
             char       *typstr;
  
             typstr = sv2cstr(argv[i]);
             (void) parseTypeString(typstr, &typId, &typmod, NULL);
             pfree(typstr);
  
             getTypeInputInfo(typId, &typInput, &typIOParam);
  
             qdesc->argtypes[i] = typId;
             fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
             qdesc->argtypioparams[i] = typIOParam;
         }
  
         /* Make sure the query is validly encoded */
         pg_verifymbstr(query, strlen(query), false);
  
         /************************************************************
          * Prepare the plan and check for errors
          ************************************************************/
         plan = SPI_prepare(query, argc, qdesc->argtypes);
  
         if (plan == NULL)
             elog(ERROR, "SPI_prepare() failed:%s",
                  SPI_result_code_string(SPI_result));
  
         /************************************************************
          * Save the plan into permanent memory (right now it's in the
          * SPI procCxt, which will go away at function end).
          ************************************************************/
         if (SPI_keepplan(plan))
             elog(ERROR, "SPI_keepplan() failed");
         qdesc->plan = plan;
  
         /************************************************************
          * Insert a hashtable entry for the plan.
          ************************************************************/
         hash_entry = hash_search(plperl_active_interp->query_hash,
                                  qdesc->qname,
                                  HASH_ENTER, &found);
         hash_entry->query_data = qdesc;
  
         /* Get rid of workspace */
         MemoryContextDelete(work_cxt);
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Drop anything we managed to allocate */
         if (hash_entry)
             hash_search(plperl_active_interp->query_hash,
                         qdesc->qname,
                         HASH_REMOVE, NULL);
         if (plan_cxt)
             MemoryContextDelete(plan_cxt);
         if (plan)
             SPI_freeplan(plan);
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     /************************************************************
      * Return the query's hash key to the caller.
      ************************************************************/
     return cstr2sv(qdesc->qname);
 }

References ALLOCSET_DEFAULT_SIZES, ALLOCSET_SMALL_SIZES, AllocSetContextCreate, plperl_query_desc::arginfuncs, plperl_query_desc::argtypes, plperl_query_desc::argtypioparams, BeginInternalSubTransaction(), CHECK_FOR_INTERRUPTS, check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), cstr2sv(), CurrentMemoryContext, CurrentResourceOwner, elog, ERROR, FlushErrorState(), fmgr_info_cxt(), getTypeInputInfo(), HASH_ENTER, HASH_REMOVE, hash_search(), i, MemoryContextDelete(), MemoryContextSwitchTo(), ErrorData::message, plperl_query_desc::nargs, palloc(), palloc0(), parseTypeString(), pfree(), PG_CATCH, PG_END_TRY, PG_TRY, pg_verifymbstr(), plperl_query_desc::plan, plan, plperl_query_desc::plan_cxt, plperl_active_interp, plperl_query_desc::qname, plperl_query_entry::query_data, plperl_interp_desc::query_hash, ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), snprintf, SPI_freeplan(), SPI_keepplan(), SPI_prepare(), SPI_result, SPI_result_code_string(), sv2cstr(), and TopMemoryContext.

◆ plperl_spi_query()

SV* plperl_spi_query ( char * query )

Definition at line 3404 of file plperl.c.

 {
     SV         *cursor;
  
     /*
      * Execute the query inside a sub-transaction, so we can cope with errors
      * sanely
      */
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     /* Want to run inside function's memory context */
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         SPIPlanPtr  plan;
         Portal      portal;
  
         /* Make sure the query is validly encoded */
         pg_verifymbstr(query, strlen(query), false);
  
         /* Create a cursor for the query */
         plan = SPI_prepare(query, 0, NULL);
         if (plan == NULL)
             elog(ERROR, "SPI_prepare() failed:%s",
                  SPI_result_code_string(SPI_result));
  
         portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
         SPI_freeplan(plan);
         if (portal == NULL)
             elog(ERROR, "SPI_cursor_open() failed:%s",
                  SPI_result_code_string(SPI_result));
         cursor = cstr2sv(portal->name);
  
         PinPortal(portal);
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     return cursor;
 }

References BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), cstr2sv(), CurrentMemoryContext, CurrentResourceOwner, elog, ERROR, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, PortalData::name, PG_CATCH, PG_END_TRY, PG_TRY, pg_verifymbstr(), PinPortal(), plan, ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_cursor_open(), SPI_freeplan(), SPI_prepare(), SPI_result, and SPI_result_code_string().

◆ plperl_spi_query_prepared()

SV* plperl_spi_query_prepared	(	char *	query,
		int	argc,
		SV **	argv
	)

Definition at line 3842 of file plperl.c.

 {
     int         i;
     char       *nulls;
     Datum      *argvalues;
     plperl_query_desc *qdesc;
     plperl_query_entry *hash_entry;
     SV         *cursor;
     Portal      portal = NULL;
  
     /*
      * Execute the query inside a sub-transaction, so we can cope with errors
      * sanely
      */
     MemoryContext oldcontext = CurrentMemoryContext;
     ResourceOwner oldowner = CurrentResourceOwner;
  
     check_spi_usage_allowed();
  
     BeginInternalSubTransaction(NULL);
     /* Want to run inside function's memory context */
     MemoryContextSwitchTo(oldcontext);
  
     PG_TRY();
     {
         /************************************************************
          * Fetch the saved plan descriptor, see if it's o.k.
          ************************************************************/
         hash_entry = hash_search(plperl_active_interp->query_hash, query,
                                  HASH_FIND, NULL);
         if (hash_entry == NULL)
             elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
  
         qdesc = hash_entry->query_data;
         if (qdesc == NULL)
             elog(ERROR, "spi_query_prepared: plperl query_hash value vanished");
  
         if (qdesc->nargs != argc)
             elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
                  qdesc->nargs, argc);
  
         /************************************************************
          * Set up arguments
          ************************************************************/
         if (argc > 0)
         {
             nulls = (char *) palloc(argc);
             argvalues = (Datum *) palloc(argc * sizeof(Datum));
         }
         else
         {
             nulls = NULL;
             argvalues = NULL;
         }
  
         for (i = 0; i < argc; i++)
         {
             bool        isnull;
  
             argvalues[i] = plperl_sv_to_datum(argv[i],
                                               qdesc->argtypes[i],
                                               -1,
                                               NULL,
                                               &qdesc->arginfuncs[i],
                                               qdesc->argtypioparams[i],
                                               &isnull);
             nulls[i] = isnull ? 'n' : ' ';
         }
  
         /************************************************************
          * go
          ************************************************************/
         portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
                                  current_call_data->prodesc->fn_readonly);
         if (argc > 0)
         {
             pfree(argvalues);
             pfree(nulls);
         }
         if (portal == NULL)
             elog(ERROR, "SPI_cursor_open() failed:%s",
                  SPI_result_code_string(SPI_result));
  
         cursor = cstr2sv(portal->name);
  
         PinPortal(portal);
  
         /* Commit the inner transaction, return to outer xact context */
         ReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Abort the inner transaction */
         RollbackAndReleaseCurrentSubTransaction();
         MemoryContextSwitchTo(oldcontext);
         CurrentResourceOwner = oldowner;
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
  
         /* Can't get here, but keep compiler quiet */
         return NULL;
     }
     PG_END_TRY();
  
     return cursor;
 }

References plperl_query_desc::arginfuncs, plperl_query_desc::argtypes, plperl_query_desc::argtypioparams, BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), cstr2sv(), current_call_data, CurrentMemoryContext, CurrentResourceOwner, elog, ERROR, FlushErrorState(), plperl_proc_desc::fn_readonly, HASH_FIND, hash_search(), i, MemoryContextSwitchTo(), ErrorData::message, PortalData::name, plperl_query_desc::nargs, palloc(), pfree(), PG_CATCH, PG_END_TRY, PG_TRY, PinPortal(), plperl_query_desc::plan, plperl_active_interp, plperl_sv_to_datum(), plperl_call_data::prodesc, plperl_query_entry::query_data, plperl_interp_desc::query_hash, ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_cursor_open(), SPI_result, and SPI_result_code_string().

◆ plperl_spi_rollback()

void plperl_spi_rollback ( void )

Definition at line 4017 of file plperl.c.

 {
     MemoryContext oldcontext = CurrentMemoryContext;
  
     check_spi_usage_allowed();
  
     PG_TRY();
     {
         SPI_rollback();
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Save error info */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
     }
     PG_END_TRY();
 }

References check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), CurrentMemoryContext, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, PG_CATCH, PG_END_TRY, PG_TRY, and SPI_rollback().

◆ plperl_sv_to_datum()

static Datum plperl_sv_to_datum	(	SV *	sv,
		Oid	typid,
		int32	typmod,
		FunctionCallInfo	fcinfo,
		FmgrInfo *	finfo,
		Oid	typioparam,
		bool *	isnull
	)

static

Definition at line 1323 of file plperl.c.

 {
     FmgrInfo    tmp;
     Oid         funcid;
  
     /* we might recurse */
     check_stack_depth();
  
     *isnull = false;
  
     /*
      * Return NULL if result is undef, or if we're in a function returning
      * VOID.  In the latter case, we should pay no attention to the last Perl
      * statement's result, and this is a convenient means to ensure that.
      */
     if (!sv || !SvOK(sv) || typid == VOIDOID)
     {
         /* look up type info if they did not pass it */
         if (!finfo)
         {
             _sv_to_datum_finfo(typid, &tmp, &typioparam);
             finfo = &tmp;
         }
         *isnull = true;
         /* must call typinput in case it wants to reject NULL */
         return InputFunctionCall(finfo, NULL, typioparam, typmod);
     }
     else if ((funcid = get_transform_tosql(typid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes)))
         return OidFunctionCall1(funcid, PointerGetDatum(sv));
     else if (SvROK(sv))
     {
         /* handle references */
         SV         *sav = get_perl_array_ref(sv);
  
         if (sav)
         {
             /* handle an arrayref */
             return plperl_array_to_datum(sav, typid, typmod);
         }
         else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
         {
             /* handle a hashref */
             Datum       ret;
             TupleDesc   td;
             bool        isdomain;
  
             if (!type_is_rowtype(typid))
                 ereport(ERROR,
                         (errcode(ERRCODE_DATATYPE_MISMATCH),
                          errmsg("cannot convert Perl hash to non-composite type %s",
                                 format_type_be(typid))));
  
             td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
             if (td != NULL)
             {
                 /* Did we look through a domain? */
                 isdomain = (typid != td->tdtypeid);
             }
             else
             {
                 /* Must be RECORD, try to resolve based on call info */
                 TypeFuncClass funcclass;
  
                 if (fcinfo)
                     funcclass = get_call_result_type(fcinfo, &typid, &td);
                 else
                     funcclass = TYPEFUNC_OTHER;
                 if (funcclass != TYPEFUNC_COMPOSITE &&
                     funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
                     ereport(ERROR,
                             (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                              errmsg("function returning record called in context "
                                     "that cannot accept type record")));
                 Assert(td);
                 isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
             }
  
             ret = plperl_hash_to_datum(sv, td);
  
             if (isdomain)
                 domain_check(ret, false, typid, NULL, NULL);
  
             /* Release on the result of get_call_result_type is harmless */
             ReleaseTupleDesc(td);
  
             return ret;
         }
  
         /*
          * If it's a reference to something else, such as a scalar, just
          * recursively look through the reference.
          */
         return plperl_sv_to_datum(SvRV(sv), typid, typmod,
                                   fcinfo, finfo, typioparam,
                                   isnull);
     }
     else
     {
         /* handle a string/number */
         Datum       ret;
         char       *str = sv2cstr(sv);
  
         /* did not pass in any typeinfo? look it up */
         if (!finfo)
         {
             _sv_to_datum_finfo(typid, &tmp, &typioparam);
             finfo = &tmp;
         }
  
         ret = InputFunctionCall(finfo, str, typioparam, typmod);
         pfree(str);
  
         return ret;
     }
 }

References _sv_to_datum_finfo(), Assert, check_stack_depth(), current_call_data, domain_check(), ereport, errcode(), errmsg(), ERROR, format_type_be(), get_call_result_type(), get_perl_array_ref(), get_transform_tosql(), InputFunctionCall(), plperl_proc_desc::lang_oid, lookup_rowtype_tupdesc_domain(), OidFunctionCall1, pfree(), plperl_array_to_datum(), plperl_hash_to_datum(), PointerGetDatum(), plperl_call_data::prodesc, ReleaseTupleDesc, str, sv2cstr(), TupleDescData::tdtypeid, plperl_proc_desc::trftypes, type_is_rowtype(), TYPEFUNC_COMPOSITE, TYPEFUNC_COMPOSITE_DOMAIN, and TYPEFUNC_OTHER.

Referenced by array_to_datum_internal(), plperl_build_tuple_result(), plperl_func_handler(), plperl_modify_tuple(), plperl_return_next_internal(), plperl_spi_exec_prepared(), plperl_spi_query_prepared(), and plperl_sv_to_literal().

◆ plperl_sv_to_literal()

char* plperl_sv_to_literal	(	SV *	sv,
		char *	fqtypename
	)

Definition at line 1444 of file plperl.c.

 {
     Oid         typid;
     Oid         typoutput;
     Datum       datum;
     bool        typisvarlena,
                 isnull;
  
     check_spi_usage_allowed();
  
     typid = DirectFunctionCall1(regtypein, CStringGetDatum(fqtypename));
     if (!OidIsValid(typid))
         ereport(ERROR,
                 (errcode(ERRCODE_UNDEFINED_OBJECT),
                  errmsg("lookup failed for type %s", fqtypename)));
  
     datum = plperl_sv_to_datum(sv,
                                typid, -1,
                                NULL, NULL, InvalidOid,
                                &isnull);
  
     if (isnull)
         return NULL;
  
     getTypeOutputInfo(typid,
                       &typoutput, &typisvarlena);
  
     return OidOutputFunctionCall(typoutput, datum);
 }

References check_spi_usage_allowed(), CStringGetDatum(), DirectFunctionCall1, ereport, errcode(), errmsg(), ERROR, getTypeOutputInfo(), InvalidOid, OidIsValid, OidOutputFunctionCall(), plperl_sv_to_datum(), and regtypein().

◆ plperl_trigger_build_args()

static SV* plperl_trigger_build_args ( FunctionCallInfo fcinfo )

static

Definition at line 1631 of file plperl.c.

 {
     dTHX;
     TriggerData *tdata;
     TupleDesc   tupdesc;
     int         i;
     char       *level;
     char       *event;
     char       *relid;
     char       *when;
     HV         *hv;
  
     hv = newHV();
     hv_ksplit(hv, 12);          /* pre-grow the hash */
  
     tdata = (TriggerData *) fcinfo->context;
     tupdesc = tdata->tg_relation->rd_att;
  
     relid = DatumGetCString(DirectFunctionCall1(oidout,
                                                 ObjectIdGetDatum(tdata->tg_relation->rd_id)));
  
     hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
     hv_store_string(hv, "relid", cstr2sv(relid));
  
     /*
      * Note: In BEFORE trigger, stored generated columns are not computed yet,
      * so don't make them accessible in NEW row.
      */
  
     if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
     {
         event = "INSERT";
         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
             hv_store_string(hv, "new",
                             plperl_hash_from_tuple(tdata->tg_trigtuple,
                                                    tupdesc,
                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
     }
     else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
     {
         event = "DELETE";
         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
             hv_store_string(hv, "old",
                             plperl_hash_from_tuple(tdata->tg_trigtuple,
                                                    tupdesc,
                                                    true));
     }
     else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
     {
         event = "UPDATE";
         if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
         {
             hv_store_string(hv, "old",
                             plperl_hash_from_tuple(tdata->tg_trigtuple,
                                                    tupdesc,
                                                    true));
             hv_store_string(hv, "new",
                             plperl_hash_from_tuple(tdata->tg_newtuple,
                                                    tupdesc,
                                                    !TRIGGER_FIRED_BEFORE(tdata->tg_event)));
         }
     }
     else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
         event = "TRUNCATE";
     else
         event = "UNKNOWN";
  
     hv_store_string(hv, "event", cstr2sv(event));
     hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
  
     if (tdata->tg_trigger->tgnargs > 0)
     {
         AV         *av = newAV();
  
         av_extend(av, tdata->tg_trigger->tgnargs);
         for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
             av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
         hv_store_string(hv, "args", newRV_noinc((SV *) av));
     }
  
     hv_store_string(hv, "relname",
                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
  
     hv_store_string(hv, "table_name",
                     cstr2sv(SPI_getrelname(tdata->tg_relation)));
  
     hv_store_string(hv, "table_schema",
                     cstr2sv(SPI_getnspname(tdata->tg_relation)));
  
     if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
         when = "BEFORE";
     else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
         when = "AFTER";
     else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
         when = "INSTEAD OF";
     else
         when = "UNKNOWN";
     hv_store_string(hv, "when", cstr2sv(when));
  
     if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
         level = "ROW";
     else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
         level = "STATEMENT";
     else
         level = "UNKNOWN";
     hv_store_string(hv, "level", cstr2sv(level));
  
     return newRV_noinc((SV *) hv);
 }

References av, FunctionCallInfoBaseData::context, cstr2sv(), DatumGetCString(), DirectFunctionCall1, dTHX, hv_store_string(), i, newRV_noinc, ObjectIdGetDatum(), oidout(), plperl_hash_from_tuple(), RelationData::rd_att, RelationData::rd_id, SPI_getnspname(), SPI_getrelname(), TriggerData::tg_event, TriggerData::tg_newtuple, TriggerData::tg_relation, TriggerData::tg_trigger, TriggerData::tg_trigtuple, Trigger::tgargs, Trigger::tgname, Trigger::tgnargs, TRIGGER_FIRED_AFTER, TRIGGER_FIRED_BEFORE, TRIGGER_FIRED_BY_DELETE, TRIGGER_FIRED_BY_INSERT, TRIGGER_FIRED_BY_TRUNCATE, TRIGGER_FIRED_BY_UPDATE, TRIGGER_FIRED_FOR_ROW, TRIGGER_FIRED_FOR_STATEMENT, and TRIGGER_FIRED_INSTEAD.

Referenced by plperl_trigger_handler().

◆ plperl_trigger_handler()

static Datum plperl_trigger_handler ( PG_FUNCTION_ARGS )

static

Definition at line 2521 of file plperl.c.

 {
     plperl_proc_desc *prodesc;
     SV         *perlret;
     Datum       retval;
     SV         *svTD;
     HV         *hvTD;
     ErrorContextCallback pl_error_context;
     TriggerData *tdata;
     int         rc PG_USED_FOR_ASSERTS_ONLY;
  
     /* Connect to SPI manager */
     if (SPI_connect() != SPI_OK_CONNECT)
         elog(ERROR, "could not connect to SPI manager");
  
     /* Make transition tables visible to this SPI connection */
     tdata = (TriggerData *) fcinfo->context;
     rc = SPI_register_trigger_data(tdata);
     Assert(rc >= 0);
  
     /* Find or compile the function */
     prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false);
     current_call_data->prodesc = prodesc;
     increment_prodesc_refcount(prodesc);
  
     /* Set a callback for error reporting */
     pl_error_context.callback = plperl_exec_callback;
     pl_error_context.previous = error_context_stack;
     pl_error_context.arg = prodesc->proname;
     error_context_stack = &pl_error_context;
  
     activate_interpreter(prodesc->interp);
  
     svTD = plperl_trigger_build_args(fcinfo);
     perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
     hvTD = (HV *) SvRV(svTD);
  
     /************************************************************
     * Disconnect from SPI manager and then create the return
     * values datum (if the input function does a palloc for it
     * this must not be allocated in the SPI memory context
     * because SPI_finish would free it).
     ************************************************************/
     if (SPI_finish() != SPI_OK_FINISH)
         elog(ERROR, "SPI_finish() failed");
  
     if (perlret == NULL || !SvOK(perlret))
     {
         /* undef result means go ahead with original tuple */
         TriggerData *trigdata = ((TriggerData *) fcinfo->context);
  
         if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
             retval = (Datum) trigdata->tg_trigtuple;
         else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
             retval = (Datum) trigdata->tg_newtuple;
         else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event))
             retval = (Datum) trigdata->tg_trigtuple;
         else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event))
             retval = (Datum) trigdata->tg_trigtuple;
         else
             retval = (Datum) 0; /* can this happen? */
     }
     else
     {
         HeapTuple   trv;
         char       *tmp;
  
         tmp = sv2cstr(perlret);
  
         if (pg_strcasecmp(tmp, "SKIP") == 0)
             trv = NULL;
         else if (pg_strcasecmp(tmp, "MODIFY") == 0)
         {
             TriggerData *trigdata = (TriggerData *) fcinfo->context;
  
             if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event))
                 trv = plperl_modify_tuple(hvTD, trigdata,
                                           trigdata->tg_trigtuple);
             else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event))
                 trv = plperl_modify_tuple(hvTD, trigdata,
                                           trigdata->tg_newtuple);
             else
             {
                 ereport(WARNING,
                         (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
                          errmsg("ignoring modified row in DELETE trigger")));
                 trv = NULL;
             }
         }
         else
         {
             ereport(ERROR,
                     (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED),
                      errmsg("result of PL/Perl trigger function must be undef, "
                             "\"SKIP\", or \"MODIFY\"")));
             trv = NULL;
         }
         retval = PointerGetDatum(trv);
         pfree(tmp);
     }
  
     /* Restore the previous error callback */
     error_context_stack = pl_error_context.previous;
  
     SvREFCNT_dec_current(svTD);
     if (perlret)
         SvREFCNT_dec_current(perlret);
  
     return retval;
 }

References activate_interpreter(), ErrorContextCallback::arg, Assert, ErrorContextCallback::callback, compile_plperl_function(), current_call_data, elog, ereport, errcode(), errmsg(), ERROR, error_context_stack, if(), increment_prodesc_refcount, plperl_proc_desc::interp, pfree(), pg_strcasecmp(), PG_USED_FOR_ASSERTS_ONLY, plperl_call_perl_trigger_func(), plperl_exec_callback(), plperl_modify_tuple(), plperl_trigger_build_args(), PointerGetDatum(), ErrorContextCallback::previous, plperl_call_data::prodesc, plperl_proc_desc::proname, SPI_connect(), SPI_finish(), SPI_OK_CONNECT, SPI_OK_FINISH, SPI_register_trigger_data(), sv2cstr(), SvREFCNT_dec_current(), TriggerData::tg_event, TriggerData::tg_newtuple, TriggerData::tg_trigtuple, TRIGGER_FIRED_BY_DELETE, TRIGGER_FIRED_BY_INSERT, TRIGGER_FIRED_BY_TRUNCATE, TRIGGER_FIRED_BY_UPDATE, and WARNING.

Referenced by plperl_call_handler().

◆ plperl_trusted_init()

static void plperl_trusted_init ( void )

static

Definition at line 957 of file plperl.c.

 {
     dTHX;
     HV         *stash;
     SV         *sv;
     char       *key;
     I32         klen;
  
     /* use original require while we set up */
     PL_ppaddr[OP_REQUIRE] = pp_require_orig;
     PL_ppaddr[OP_DOFILE] = pp_require_orig;
  
     eval_pv(PLC_TRUSTED, FALSE);
     if (SvTRUE(ERRSV))
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                  errcontext("while executing PLC_TRUSTED")));
  
     /*
      * Force loading of utf8 module now to prevent errors that can arise from
      * the regex code later trying to load utf8 modules. See
      * http://rt.perl.org/rt3/Ticket/Display.html?id=47576
      */
     eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE);
     if (SvTRUE(ERRSV))
         ereport(ERROR,
                 (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                  errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                  errcontext("while executing utf8fix")));
  
     /*
      * Lock down the interpreter
      */
  
     /* switch to the safe require/dofile opcode for future code */
     PL_ppaddr[OP_REQUIRE] = pp_require_safe;
     PL_ppaddr[OP_DOFILE] = pp_require_safe;
  
     /*
      * prevent (any more) unsafe opcodes being compiled PL_op_mask is per
      * interpreter, so this only needs to be set once
      */
     PL_op_mask = plperl_opmask;
  
     /* delete the DynaLoader:: namespace so extensions can't be loaded */
     stash = gv_stashpv("DynaLoader", GV_ADDWARN);
     hv_iterinit(stash);
     while ((sv = hv_iternextsv(stash, &key, &klen)))
     {
         if (!isGV_with_GP(sv) || !GvCV(sv))
             continue;
         SvREFCNT_dec(GvCV(sv)); /* free the CV */
         GvCV_set(sv, NULL);     /* prevent call via GV */
     }
     hv_clear(stash);
  
     /* invalidate assorted caches */
     ++PL_sub_generation;
     hv_clear(PL_stashcache);
  
     /*
      * Execute plperl.on_plperl_init in the locked-down interpreter
      */
     if (plperl_on_plperl_init && *plperl_on_plperl_init)
     {
         eval_pv(plperl_on_plperl_init, FALSE);
         /* XXX need to find a way to determine a better errcode here */
         if (SvTRUE(ERRSV))
             ereport(ERROR,
                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                      errcontext("while executing plperl.on_plperl_init")));
     }
 }

References dTHX, ereport, errcode(), errcontext, errmsg(), ERROR, ERRSV, GvCV_set, isGV_with_GP, sort-test::key, PL_ppaddr, plperl_on_plperl_init, plperl_opmask, pp_require_orig, pp_require_safe(), strip_trailing_ws(), and sv2cstr().

Referenced by select_perl_context().

◆ plperl_untrusted_init()

static void plperl_untrusted_init ( void )

static

Definition at line 1038 of file plperl.c.

 {
     dTHX;
  
     /*
      * Nothing to do except execute plperl.on_plperlu_init
      */
     if (plperl_on_plperlu_init && *plperl_on_plperlu_init)
     {
         eval_pv(plperl_on_plperlu_init, FALSE);
         if (SvTRUE(ERRSV))
             ereport(ERROR,
                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                      errcontext("while executing plperl.on_plperlu_init")));
     }
 }

References dTHX, ereport, errcode(), errcontext, errmsg(), ERROR, ERRSV, plperl_on_plperlu_init, strip_trailing_ws(), and sv2cstr().

Referenced by select_perl_context().

◆ plperl_util_elog()

void plperl_util_elog	(	int	level,
		SV *	msg
	)

Definition at line 4054 of file plperl.c.

 {
     MemoryContext oldcontext = CurrentMemoryContext;
     char       *volatile cmsg = NULL;
  
     /*
      * We intentionally omit check_spi_usage_allowed() here, as this seems
      * safe to allow even in the contexts that that function rejects.
      */
  
     PG_TRY();
     {
         cmsg = sv2cstr(msg);
         elog(level, "%s", cmsg);
         pfree(cmsg);
     }
     PG_CATCH();
     {
         ErrorData  *edata;
  
         /* Must reset elog.c's state */
         MemoryContextSwitchTo(oldcontext);
         edata = CopyErrorData();
         FlushErrorState();
  
         if (cmsg)
             pfree(cmsg);
  
         /* Punt the error to Perl */
         croak_cstr(edata->message);
     }
     PG_END_TRY();
 }

References CopyErrorData(), croak_cstr(), CurrentMemoryContext, elog, FlushErrorState(), MemoryContextSwitchTo(), ErrorData::message, pfree(), PG_CATCH, PG_END_TRY, PG_TRY, and sv2cstr().

◆ plperl_validator()

Datum plperl_validator ( PG_FUNCTION_ARGS )

Definition at line 1989 of file plperl.c.

 {
     Oid         funcoid = PG_GETARG_OID(0);
     HeapTuple   tuple;
     Form_pg_proc proc;
     char        functyptype;
     int         numargs;
     Oid        *argtypes;
     char      **argnames;
     char       *argmodes;
     bool        is_trigger = false;
     bool        is_event_trigger = false;
     int         i;
  
     if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid))
         PG_RETURN_VOID();
  
     /* Get the new function's pg_proc entry */
     tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid));
     if (!HeapTupleIsValid(tuple))
         elog(ERROR, "cache lookup failed for function %u", funcoid);
     proc = (Form_pg_proc) GETSTRUCT(tuple);
  
     functyptype = get_typtype(proc->prorettype);
  
     /* Disallow pseudotype result */
     /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */
     if (functyptype == TYPTYPE_PSEUDO)
     {
         if (proc->prorettype == TRIGGEROID)
             is_trigger = true;
         else if (proc->prorettype == EVENT_TRIGGEROID)
             is_event_trigger = true;
         else if (proc->prorettype != RECORDOID &&
                  proc->prorettype != VOIDOID)
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("PL/Perl functions cannot return type %s",
                             format_type_be(proc->prorettype))));
     }
  
     /* Disallow pseudotypes in arguments (either IN or OUT) */
     numargs = get_func_arg_info(tuple,
                                 &argtypes, &argnames, &argmodes);
     for (i = 0; i < numargs; i++)
     {
         if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO &&
             argtypes[i] != RECORDOID)
             ereport(ERROR,
                     (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                      errmsg("PL/Perl functions cannot accept type %s",
                             format_type_be(argtypes[i]))));
     }
  
     ReleaseSysCache(tuple);
  
     /* Postpone body checks if !check_function_bodies */
     if (check_function_bodies)
     {
         (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger);
     }
  
     /* the result of a validator is ignored */
     PG_RETURN_VOID();
 }

References check_function_bodies, CheckFunctionValidatorAccess(), compile_plperl_function(), elog, ereport, errcode(), errmsg(), ERROR, format_type_be(), get_func_arg_info(), get_typtype(), GETSTRUCT, HeapTupleIsValid, i, ObjectIdGetDatum(), PG_GETARG_OID, PG_RETURN_VOID, ReleaseSysCache(), and SearchSysCache1().

Referenced by plperlu_validator().

◆ plperlu_call_handler()

Datum plperlu_call_handler ( PG_FUNCTION_ARGS )

Definition at line 2067 of file plperl.c.

 {
     return plperl_call_handler(fcinfo);
 }

References plperl_call_handler().

◆ plperlu_inline_handler()

Datum plperlu_inline_handler ( PG_FUNCTION_ARGS )

Definition at line 2075 of file plperl.c.

 {
     return plperl_inline_handler(fcinfo);
 }

References plperl_inline_handler().

◆ plperlu_validator()

Datum plperlu_validator ( PG_FUNCTION_ARGS )

Definition at line 2083 of file plperl.c.

 {
     /* call plperl validator with our fcinfo so it gets our oid */
     return plperl_validator(fcinfo);
 }

References plperl_validator().

◆ pp_require_safe()

static OP * pp_require_safe ( pTHX )

static

Definition at line 880 of file plperl.c.

 {
     dVAR;
     dSP;
     SV         *sv,
               **svp;
     char       *name;
     STRLEN      len;
  
     sv = POPs;
     name = SvPV(sv, len);
     if (!(name && len > 0 && *name))
         RETPUSHNO;
  
     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
     if (svp && *svp != &PL_sv_undef)
         RETPUSHYES;
  
     DIE(aTHX_ "Unable to load %s into plperl", name);
  
     /*
      * In most Perl versions, DIE() expands to a return statement, so the next
      * line is not necessary.  But in versions between but not including
      * 5.11.1 and 5.13.3 it does not, so the next line is necessary to avoid a
      * "control reaches end of non-void function" warning from gcc.  Other
      * compilers such as Solaris Studio will, however, issue a "statement not
      * reached" warning instead.
      */
     return NULL;
 }

References aTHX_, dVAR, len, name, and PL_sv_undef.

Referenced by plperl_trusted_init(), and set_interp_require().

◆ select_perl_context()

static void select_perl_context ( bool trusted )

static

Definition at line 553 of file plperl.c.

 {
     Oid         user_id;
     plperl_interp_desc *interp_desc;
     bool        found;
     PerlInterpreter *interp = NULL;
  
     /* Find or create the interpreter hashtable entry for this userid */
     if (trusted)
         user_id = GetUserId();
     else
         user_id = InvalidOid;
  
     interp_desc = hash_search(plperl_interp_hash, &user_id,
                               HASH_ENTER,
                               &found);
     if (!found)
     {
         /* Initialize newly-created hashtable entry */
         interp_desc->interp = NULL;
         interp_desc->query_hash = NULL;
     }
  
     /* Make sure we have a query_hash for this interpreter */
     if (interp_desc->query_hash == NULL)
     {
         HASHCTL     hash_ctl;
  
         hash_ctl.keysize = NAMEDATALEN;
         hash_ctl.entrysize = sizeof(plperl_query_entry);
         interp_desc->query_hash = hash_create("PL/Perl queries",
                                               32,
                                               &hash_ctl,
                                               HASH_ELEM | HASH_STRINGS);
     }
  
     /*
      * Quick exit if already have an interpreter
      */
     if (interp_desc->interp)
     {
         activate_interpreter(interp_desc);
         return;
     }
  
     /*
      * adopt held interp if free, else create new one if possible
      */
     if (plperl_held_interp != NULL)
     {
         /* first actual use of a perl interpreter */
         interp = plperl_held_interp;
  
         /*
          * Reset the plperl_held_interp pointer first; if we fail during init
          * we don't want to try again with the partially-initialized interp.
          */
         plperl_held_interp = NULL;
  
         if (trusted)
             plperl_trusted_init();
         else
             plperl_untrusted_init();
  
         /* successfully initialized, so arrange for cleanup */
         on_proc_exit(plperl_fini, 0);
     }
     else
     {
 #ifdef MULTIPLICITY
  
         /*
          * plperl_init_interp will change Perl's idea of the active
          * interpreter.  Reset plperl_active_interp temporarily, so that if we
          * hit an error partway through here, we'll make sure to switch back
          * to a non-broken interpreter before running any other Perl
          * functions.
          */
         plperl_active_interp = NULL;
  
         /* Now build the new interpreter */
         interp = plperl_init_interp();
  
         if (trusted)
             plperl_trusted_init();
         else
             plperl_untrusted_init();
 #else
         ereport(ERROR,
                 (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
                  errmsg("cannot allocate multiple Perl interpreters on this platform")));
 #endif
     }
  
     set_interp_require(trusted);
  
     /*
      * Since the timing of first use of PL/Perl can't be predicted, any
      * database interaction during initialization is problematic. Including,
      * but not limited to, security definer issues. So we only enable access
      * to the database AFTER on_*_init code has run. See
      * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php
      */
     {
         dTHX;
  
         newXS("PostgreSQL::InServer::SPI::bootstrap",
               boot_PostgreSQL__InServer__SPI, __FILE__);
  
         eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
         if (SvTRUE(ERRSV))
             ereport(ERROR,
                     (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
                      errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))),
                      errcontext("while executing PostgreSQL::InServer::SPI::bootstrap")));
     }
  
     /* Fully initialized, so mark the hashtable entry valid */
     interp_desc->interp = interp;
  
     /* And mark this as the active interpreter */
     plperl_active_interp = interp_desc;
 }

References activate_interpreter(), boot_PostgreSQL__InServer__SPI(), dTHX, HASHCTL::entrysize, ereport, errcode(), errcontext, errmsg(), ERROR, ERRSV, GetUserId(), hash_create(), HASH_ELEM, HASH_ENTER, hash_search(), HASH_STRINGS, plperl_interp_desc::interp, InvalidOid, HASHCTL::keysize, NAMEDATALEN, on_proc_exit(), plperl_active_interp, plperl_fini(), plperl_held_interp, plperl_init_interp(), plperl_interp_hash, plperl_trusted_init(), plperl_untrusted_init(), plperl_interp_desc::query_hash, set_interp_require(), strip_trailing_ws(), and sv2cstr().

Referenced by compile_plperl_function(), and plperl_inline_handler().

◆ set_interp_require()

static void set_interp_require ( bool trusted )

static

Definition at line 490 of file plperl.c.

 {
     if (trusted)
     {
         PL_ppaddr[OP_REQUIRE] = pp_require_safe;
         PL_ppaddr[OP_DOFILE] = pp_require_safe;
     }
     else
     {
         PL_ppaddr[OP_REQUIRE] = pp_require_orig;
         PL_ppaddr[OP_DOFILE] = pp_require_orig;
     }
 }

References PL_ppaddr, pp_require_orig, and pp_require_safe().

Referenced by activate_interpreter(), and select_perl_context().

◆ split_array()

static SV * split_array	(	plperl_array_info *	info,
		int	first,
		int	last,
		int	nest
	)

static

Definition at line 1559 of file plperl.c.

 {
     dTHX;
     int         i;
     AV         *result;
  
     /* we should only be called when we have something to split */
     Assert(info->ndims > 0);
  
     /* since this function recurses, it could be driven to stack overflow */
     check_stack_depth();
  
     /*
      * Base case, return a reference to a single-dimensional array
      */
     if (nest >= info->ndims - 1)
         return make_array_ref(info, first, last);
  
     result = newAV();
     for (i = first; i < last; i += info->nelems[nest + 1])
     {
         /* Recursively form references to arrays of lower dimensions */
         SV         *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1);
  
         av_push(result, ref);
     }
     return newRV_noinc((SV *) result);
 }

References Assert, check_stack_depth(), dTHX, i, make_array_ref(), plperl_array_info::ndims, plperl_array_info::nelems, and newRV_noinc.

Referenced by plperl_ref_from_pg_array().

◆ strip_trailing_ws()

static char * strip_trailing_ws ( const char * msg )

static

Definition at line 1061 of file plperl.c.

 {
     char       *res = pstrdup(msg);
     int         len = strlen(res);
  
     while (len > 0 && isspace((unsigned char) res[len - 1]))
         res[--len] = '\0';
     return res;
 }

References len, pstrdup(), and res.

Referenced by plperl_call_perl_event_trigger_func(), plperl_call_perl_func(), plperl_call_perl_trigger_func(), plperl_create_sub(), plperl_init_interp(), plperl_trusted_init(), plperl_untrusted_init(), and select_perl_context().

◆ SvREFCNT_dec_current()

static void SvREFCNT_dec_current ( SV * sv )

inlinestatic

Definition at line 312 of file plperl.c.

 {
     dTHX;
  
     SvREFCNT_dec(sv);
 }

References dTHX.

Referenced by free_plperl_function(), plperl_event_trigger_handler(), plperl_func_handler(), plperl_inline_handler(), and plperl_trigger_handler().

◆ validate_plperl_function()

static bool validate_plperl_function	(	plperl_proc_ptr *	proc_ptr,
		HeapTuple	procTup
	)

static

Definition at line 2671 of file plperl.c.

 {
     if (proc_ptr && proc_ptr->proc_ptr)
     {
         plperl_proc_desc *prodesc = proc_ptr->proc_ptr;
         bool        uptodate;
  
         /************************************************************
          * If it's present, must check whether it's still up to date.
          * This is needed because CREATE OR REPLACE FUNCTION can modify the
          * function's pg_proc entry without changing its OID.
          ************************************************************/
         uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) &&
                     ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self));
  
         if (uptodate)
             return true;
  
         /* Otherwise, unlink the obsoleted entry from the hashtable ... */
         proc_ptr->proc_ptr = NULL;
         /* ... and release the corresponding refcount, probably deleting it */
         decrement_prodesc_refcount(prodesc);
     }
  
     return false;
 }

References decrement_prodesc_refcount, plperl_proc_desc::fn_tid, plperl_proc_desc::fn_xmin, HeapTupleHeaderGetRawXmin, ItemPointerEquals(), plperl_proc_ptr::proc_ptr, HeapTupleData::t_data, and HeapTupleData::t_self.

Referenced by compile_plperl_function().

Variable Documentation

◆ current_call_data

plperl_call_data* current_call_data = NULL

static

Definition at line 241 of file plperl.c.

Referenced by check_spi_usage_allowed(), plperl_call_handler(), plperl_call_perl_func(), plperl_event_trigger_handler(), plperl_func_handler(), plperl_hash_from_tuple(), plperl_inline_handler(), plperl_ref_from_pg_array(), plperl_return_next_internal(), plperl_spi_exec(), plperl_spi_exec_prepared(), plperl_spi_query_prepared(), plperl_sv_to_datum(), and plperl_trigger_handler().

◆ PG_MODULE_MAGIC

PG_MODULE_MAGIC

Definition at line 56 of file plperl.c.

◆ plperl_active_interp

plperl_interp_desc* plperl_active_interp = NULL

static

Definition at line 225 of file plperl.c.

Referenced by activate_interpreter(), compile_plperl_function(), free_plperl_function(), plperl_call_handler(), plperl_inline_handler(), plperl_spi_exec_prepared(), plperl_spi_freeplan(), plperl_spi_prepare(), plperl_spi_query_prepared(), and select_perl_context().

◆ plperl_ending

bool plperl_ending = false

static

Definition at line 236 of file plperl.c.

Referenced by check_spi_usage_allowed(), and plperl_fini().

◆ plperl_held_interp

PerlInterpreter* plperl_held_interp = NULL

static

Definition at line 228 of file plperl.c.

Referenced by _PG_init(), plperl_fini(), and select_perl_context().

◆ plperl_interp_hash

HTAB* plperl_interp_hash = NULL

static

Definition at line 223 of file plperl.c.

Referenced by _PG_init(), plperl_fini(), and select_perl_context().

◆ plperl_on_init

char* plperl_on_init = NULL

static

Definition at line 232 of file plperl.c.

Referenced by _PG_init(), and plperl_init_interp().

◆ plperl_on_plperl_init

char* plperl_on_plperl_init = NULL

static

Definition at line 233 of file plperl.c.

Referenced by _PG_init(), and plperl_trusted_init().

◆ plperl_on_plperlu_init

char* plperl_on_plperlu_init = NULL

static

Definition at line 234 of file plperl.c.

Referenced by _PG_init(), and plperl_untrusted_init().

◆ plperl_opmask

char plperl_opmask[MAXO]

static

Definition at line 238 of file plperl.c.

Referenced by _PG_init(), plperl_init_interp(), and plperl_trusted_init().

◆ plperl_proc_hash

HTAB* plperl_proc_hash = NULL

static

Definition at line 224 of file plperl.c.

Referenced by _PG_init(), and compile_plperl_function().

◆ plperl_use_strict

bool plperl_use_strict = false

static

Definition at line 231 of file plperl.c.

Referenced by _PG_init(), and plperl_create_sub().

◆ pp_require_orig

OP*(* pp_require_orig) (pTHX) ( pTHX ) = NULL

static

Definition at line 237 of file plperl.c.

Referenced by plperl_init_interp(), plperl_trusted_init(), and set_interp_require().

Data Structures

Macros

Typedefs

Functions

Variables

Macro Definition Documentation

◆ decrement_prodesc_refcount

◆ increment_prodesc_refcount

◆ setlocale_perl

◆ TEXTDOMAIN

Typedef Documentation

◆ plperl_array_info

◆ plperl_call_data

◆ plperl_interp_desc

◆ plperl_proc_desc

◆ plperl_proc_key

◆ plperl_proc_ptr

◆ plperl_query_desc

◆ plperl_query_entry

Function Documentation

◆ _PG_init()

◆ _sv_to_datum_finfo()

◆ activate_interpreter()

◆ array_to_datum_internal()

◆ boot_DynaLoader()

◆ boot_PostgreSQL__InServer__SPI()

◆ boot_PostgreSQL__InServer__Util()

◆ check_spi_usage_allowed()

◆ compile_plperl_function()

◆ free_plperl_function()

◆ get_perl_array_ref()

◆ hek2cstr()

◆ hv_fetch_string()

◆ hv_store_string()

◆ make_array_ref()

◆ PG_FUNCTION_INFO_V1() [1/6]

◆ PG_FUNCTION_INFO_V1() [2/6]

◆ PG_FUNCTION_INFO_V1() [3/6]

◆ PG_FUNCTION_INFO_V1() [4/6]

◆ PG_FUNCTION_INFO_V1() [5/6]

◆ PG_FUNCTION_INFO_V1() [6/6]

◆ plperl_array_to_datum()

◆ plperl_build_tuple_result()

◆ plperl_call_handler()

◆ plperl_call_perl_event_trigger_func()

◆ plperl_call_perl_func()

◆ plperl_call_perl_trigger_func()

◆ plperl_compile_callback()

◆ plperl_create_sub()

◆ plperl_destroy_interp()

◆ plperl_event_trigger_build_args()

◆ plperl_event_trigger_handler()

◆ plperl_exec_callback()

◆ plperl_fini()

◆ plperl_func_handler()

◆ plperl_hash_from_datum()

◆ plperl_hash_from_tuple()

◆ plperl_hash_to_datum()

◆ plperl_init_interp()

◆ plperl_init_shared_libs()

◆ plperl_inline_callback()

◆ plperl_inline_handler()

◆ plperl_modify_tuple()

◆ plperl_ref_from_pg_array()

◆ plperl_return_next()

◆ plperl_return_next_internal()

◆ plperl_spi_commit()

◆ plperl_spi_cursor_close()

◆ plperl_spi_exec()

◆ plperl_spi_exec_prepared()

◆ plperl_spi_execute_fetch_result()

◆ plperl_spi_fetchrow()

◆ plperl_spi_freeplan()

◆ plperl_spi_prepare()

◆ plperl_spi_query()

◆ plperl_spi_query_prepared()

◆ plperl_spi_rollback()

◆ plperl_sv_to_datum()

◆ plperl_sv_to_literal()

◆ plperl_trigger_build_args()

◆ boot_PostgreSQLInServerSPI()

◆ boot_PostgreSQLInServerUtil()