PostgreSQL Source Code  git master
plperl.c File Reference
#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_proc_fn.h"
#include "catalog/pg_type.h"
#include "commands/event_trigger.h"
#include "commands/trigger.h"
#include "executor/spi.h"
#include "funcapi.h"
#include "mb/pg_wchar.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 "plperl.h"
#include "plperl_helpers.h"
#include "perlchunks.h"
#include "plperl_opmask.h"
Include dependency graph for plperl.c:

Go to the source code of this file.

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)
 

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)
 
void _PG_init (void)
 
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_desccompile_plperl_function (Oid fn_oid, bool is_trigger, bool is_event_trigger)
 
static SV * plperl_hash_from_tuple (HeapTuple tuple, TupleDesc tupdesc)
 
static SV * plperl_hash_from_datum (Datum attr)
 
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 *astate, int *ndims, int *dims, int cur_depth, Oid arraytypid, 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)
 
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)
 
static void check_spi_usage_allowed (void)
 
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_util_elog (int level, SV *msg)
 

Variables

 PG_MODULE_MAGIC
 
static HTABplperl_interp_hash = NULL
 
static HTABplperl_proc_hash = NULL
 
static plperl_interp_descplperl_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_datacurrent_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 136 of file plperl.c.

Referenced by plperl_call_handler(), and validate_plperl_function().

◆ increment_prodesc_refcount

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

◆ TEXTDOMAIN

#define TEXTDOMAIN   PG_TEXTDOMAIN("plperl")

Definition at line 48 of file plperl.c.

Referenced by _PG_init().

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()

void _PG_init ( void  )

Definition at line 385 of file plperl.c.

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

386 {
387  /*
388  * Be sure we do initialization only once.
389  *
390  * If initialization fails due to, e.g., plperl_init_interp() throwing an
391  * exception, then we'll return here on the next usage and the user will
392  * get a rather cryptic: ERROR: attempt to redefine parameter
393  * "plperl.use_strict"
394  */
395  static bool inited = false;
396  HASHCTL hash_ctl;
397 
398  if (inited)
399  return;
400 
401  /*
402  * Support localized messages.
403  */
405 
406  /*
407  * Initialize plperl's GUCs.
408  */
409  DefineCustomBoolVariable("plperl.use_strict",
410  gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."),
411  NULL,
413  false,
414  PGC_USERSET, 0,
415  NULL, NULL, NULL);
416 
417  /*
418  * plperl.on_init is marked PGC_SIGHUP to support the idea that it might
419  * be executed in the postmaster (if plperl is loaded into the postmaster
420  * via shared_preload_libraries). This isn't really right either way,
421  * though.
422  */
423  DefineCustomStringVariable("plperl.on_init",
424  gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."),
425  NULL,
427  NULL,
428  PGC_SIGHUP, 0,
429  NULL, NULL, NULL);
430 
431  /*
432  * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a
433  * user who might not even have USAGE privilege on the plperl language
434  * could nonetheless use SET plperl.on_plperl_init='...' to influence the
435  * behaviour of any existing plperl function that they can execute (which
436  * might be SECURITY DEFINER, leading to a privilege escalation). See
437  * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and
438  * the overall thread.
439  *
440  * Note that because plperl.use_strict is USERSET, a nefarious user could
441  * set it to be applied against other people's functions. This is judged
442  * OK since the worst result would be an error. Your code oughta pass
443  * use_strict anyway ;-)
444  */
445  DefineCustomStringVariable("plperl.on_plperl_init",
446  gettext_noop("Perl initialization code to execute once when plperl is first used."),
447  NULL,
449  NULL,
450  PGC_SUSET, 0,
451  NULL, NULL, NULL);
452 
453  DefineCustomStringVariable("plperl.on_plperlu_init",
454  gettext_noop("Perl initialization code to execute once when plperlu is first used."),
455  NULL,
457  NULL,
458  PGC_SUSET, 0,
459  NULL, NULL, NULL);
460 
461  EmitWarningsOnPlaceholders("plperl");
462 
463  /*
464  * Create hash tables.
465  */
466  memset(&hash_ctl, 0, sizeof(hash_ctl));
467  hash_ctl.keysize = sizeof(Oid);
468  hash_ctl.entrysize = sizeof(plperl_interp_desc);
469  plperl_interp_hash = hash_create("PL/Perl interpreters",
470  8,
471  &hash_ctl,
473 
474  memset(&hash_ctl, 0, sizeof(hash_ctl));
475  hash_ctl.keysize = sizeof(plperl_proc_key);
476  hash_ctl.entrysize = sizeof(plperl_proc_ptr);
477  plperl_proc_hash = hash_create("PL/Perl procedures",
478  32,
479  &hash_ctl,
481 
482  /*
483  * Save the default opmask.
484  */
485  PLPERL_SET_OPMASK(plperl_opmask);
486 
487  /*
488  * Create the first Perl interpreter, but only partially initialize it.
489  */
491 
492  inited = true;
493 }
static char plperl_opmask[MAXO]
Definition: plperl.c:245
static PerlInterpreter * plperl_init_interp(void)
Definition: plperl.c:713
static HTAB * plperl_proc_hash
Definition: plperl.c:231
#define TEXTDOMAIN
Definition: plperl.c:48
#define HASH_ELEM
Definition: hsearch.h:87
static char * plperl_on_init
Definition: plperl.c:239
struct plperl_interp_desc plperl_interp_desc
Size entrysize
Definition: hsearch.h:73
#define gettext_noop(x)
Definition: c.h:981
unsigned int Oid
Definition: postgres_ext.h:31
Definition: guc.h:75
void EmitWarningsOnPlaceholders(const char *className)
Definition: guc.c:7886
Definition: guc.h:72
#define HASH_BLOBS
Definition: hsearch.h:88
void DefineCustomStringVariable(const char *name, const char *short_desc, const char *long_desc, char **valueAddr, const char *bootValue, GucContext context, int flags, GucStringCheckHook check_hook, GucStringAssignHook assign_hook, GucShowHook show_hook)
Definition: guc.c:7833
HTAB * hash_create(const char *tabname, long nelem, HASHCTL *info, int flags)
Definition: dynahash.c:316
Size keysize
Definition: hsearch.h:72
static char * plperl_on_plperl_init
Definition: plperl.c:240
static bool plperl_use_strict
Definition: plperl.c:238
static char * plperl_on_plperlu_init
Definition: plperl.c:241
struct plperl_proc_key plperl_proc_key
static PerlInterpreter * plperl_held_interp
Definition: plperl.c:235
static HTAB * plperl_interp_hash
Definition: plperl.c:230
void pg_bindtextdomain(const char *domain)
Definition: miscinit.c:1511
void DefineCustomBoolVariable(const char *name, const char *short_desc, const char *long_desc, bool *valueAddr, bool bootValue, GucContext context, int flags, GucBoolCheckHook check_hook, GucBoolAssignHook assign_hook, GucShowHook show_hook)
Definition: guc.c:7747
struct plperl_proc_ptr plperl_proc_ptr

◆ _sv_to_datum_finfo()

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

Definition at line 1292 of file plperl.c.

References fmgr_info(), and getTypeInputInfo().

Referenced by plperl_array_to_datum(), and plperl_sv_to_datum().

1293 {
1294  Oid typinput;
1295 
1296  /* XXX would be better to cache these lookups */
1297  getTypeInputInfo(typid,
1298  &typinput, typioparam);
1299  fmgr_info(typinput, finfo);
1300 }
unsigned int Oid
Definition: postgres_ext.h:31
void fmgr_info(Oid functionId, FmgrInfo *finfo)
Definition: fmgr.c:122
void getTypeInputInfo(Oid type, Oid *typInput, Oid *typIOParam)
Definition: lsyscache.c:2613

◆ activate_interpreter()

static void activate_interpreter ( plperl_interp_desc interp_desc)
static

Definition at line 692 of file plperl.c.

References Assert, plperl_interp_desc::interp, OidIsValid, 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().

693 {
694  if (interp_desc && plperl_active_interp != interp_desc)
695  {
696  Assert(interp_desc->interp);
697  PERL_SET_CONTEXT(interp_desc->interp);
698  /* trusted iff user_id isn't InvalidOid */
699  set_interp_require(OidIsValid(interp_desc->user_id));
700  plperl_active_interp = interp_desc;
701  }
702 }
static void set_interp_require(bool trusted)
Definition: plperl.c:497
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
PerlInterpreter * interp
Definition: plperl.c:93
#define OidIsValid(objectId)
Definition: c.h:576
#define Assert(condition)
Definition: c.h:670

◆ array_to_datum_internal()

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

Definition at line 1173 of file plperl.c.

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

Referenced by plperl_array_to_datum().

1177 {
1178  dTHX;
1179  int i;
1180  int len = av_len(av) + 1;
1181 
1182  for (i = 0; i < len; i++)
1183  {
1184  /* fetch the array element */
1185  SV **svp = av_fetch(av, i, FALSE);
1186 
1187  /* see if this element is an array, if so get that */
1188  SV *sav = svp ? get_perl_array_ref(*svp) : NULL;
1189 
1190  /* multi-dimensional array? */
1191  if (sav)
1192  {
1193  AV *nav = (AV *) SvRV(sav);
1194 
1195  /* dimensionality checks */
1196  if (cur_depth + 1 > MAXDIM)
1197  ereport(ERROR,
1198  (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
1199  errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)",
1200  cur_depth + 1, MAXDIM)));
1201 
1202  /* set size when at first element in this level, else compare */
1203  if (i == 0 && *ndims == cur_depth)
1204  {
1205  dims[*ndims] = av_len(nav) + 1;
1206  (*ndims)++;
1207  }
1208  else if (av_len(nav) + 1 != dims[cur_depth])
1209  ereport(ERROR,
1210  (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
1211  errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1212 
1213  /* recurse to fetch elements of this sub-array */
1214  array_to_datum_internal(nav, astate,
1215  ndims, dims, cur_depth + 1,
1216  arraytypid, elemtypid, typmod,
1217  finfo, typioparam);
1218  }
1219  else
1220  {
1221  Datum dat;
1222  bool isnull;
1223 
1224  /* scalar after some sub-arrays at same level? */
1225  if (*ndims != cur_depth)
1226  ereport(ERROR,
1227  (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
1228  errmsg("multidimensional arrays must have array expressions with matching dimensions")));
1229 
1230  dat = plperl_sv_to_datum(svp ? *svp : NULL,
1231  elemtypid,
1232  typmod,
1233  NULL,
1234  finfo,
1235  typioparam,
1236  &isnull);
1237 
1238  (void) accumArrayResult(astate, dat, isnull,
1239  elemtypid, CurrentMemoryContext);
1240  }
1241  }
1242 }
static SV * get_perl_array_ref(SV *sv)
Definition: plperl.c:1146
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
#define dTHX
Definition: ppport.h:3208
#define MAXDIM
Definition: c.h:467
#define FALSE
Definition: ecpglib.h:39
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERROR
Definition: elog.h:43
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
#define ereport(elevel, rest)
Definition: elog.h:122
struct @18::@19 av[32]
uintptr_t Datum
Definition: postgres.h:372
ArrayBuildState * accumArrayResult(ArrayBuildState *astate, Datum dvalue, bool disnull, Oid element_type, MemoryContext rcontext)
Definition: arrayfuncs.c:5042
int errmsg(const char *fmt,...)
Definition: elog.c:797
int i
static void array_to_datum_internal(AV *av, ArrayBuildState *astate, int *ndims, int *dims, int cur_depth, Oid arraytypid, Oid elemtypid, int32 typmod, FmgrInfo *finfo, Oid typioparam)
Definition: plperl.c:1173

◆ boot_DynaLoader()

EXTERN_C void boot_DynaLoader ( pTHX_ CV *  cv)

Referenced by plperl_init_shared_libs().

◆ boot_PostgreSQL__InServer__SPI()

EXTERN_C void boot_PostgreSQL__InServer__SPI ( pTHX_ CV *  cv)

Referenced by select_perl_context().

◆ boot_PostgreSQL__InServer__Util()

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 3089 of file plperl.c.

References plperl_ending.

Referenced by 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(), and plperl_spi_query_prepared().

3090 {
3091  /* see comment in plperl_fini() */
3092  if (plperl_ending)
3093  {
3094  /* simple croak as we don't want to involve PostgreSQL code */
3095  croak("SPI functions can not be used in END blocks");
3096  }
3097 }
static bool plperl_ending
Definition: plperl.c:243

◆ compile_plperl_function()

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

Definition at line 2705 of file plperl.c.

References activate_interpreter(), ALLOCSET_SMALL_SIZES, AllocSetContextCreate(), Anum_pg_proc_prosrc, Anum_pg_proc_protrftypes, ErrorContextCallback::arg, plperl_proc_desc::arg_arraytype, plperl_proc_desc::arg_is_rowtype, plperl_proc_desc::arg_out_func, ErrorContextCallback::callback, elog, ereport, errcode(), errmsg(), ERROR, error_context_stack, EVTTRIGGEROID, fmgr_info_cxt(), plperl_proc_desc::fn_cxt, plperl_proc_desc::fn_readonly, plperl_proc_desc::fn_refcount, plperl_proc_desc::fn_retisarray, plperl_proc_desc::fn_retisset, plperl_proc_desc::fn_retistuple, plperl_proc_desc::fn_tid, plperl_proc_desc::fn_xmin, format_type_be(), free_plperl_function(), GETSTRUCT, getTypeIOParam(), GetUserId(), HASH_ENTER, HASH_FIND, hash_search(), HeapTupleGetOid, HeapTupleHeaderGetRawXmin, HeapTupleIsValid, i, increment_prodesc_refcount, plperl_proc_desc::interp, InvalidOid, plperl_proc_key::is_trigger, plperl_proc_desc::lang_oid, LANGOID, plperl_proc_desc::lanpltrusted, MemoryContextDelete(), MemoryContextSwitchTo(), NameStr, plperl_proc_desc::nargs, NIL, ObjectIdGetDatum, oid_array_to_list(), palloc0(), pfree(), PG_CATCH, PG_END_TRY, PG_RE_THROW, PG_TRY, plperl_active_interp, plperl_compile_callback(), plperl_create_sub(), ErrorContextCallback::previous, plperl_proc_key::proc_id, plperl_proc_ptr::proc_ptr, PROCOID, plperl_proc_desc::proname, PROVOLATILE_VOLATILE, pstrdup(), RECORDOID, plperl_proc_desc::reference, ReleaseSysCache(), plperl_proc_desc::result_in_func, plperl_proc_desc::result_oid, plperl_proc_desc::result_typioparam, SearchSysCache1(), select_perl_context(), SysCacheGetAttr(), HeapTupleData::t_data, HeapTupleData::t_self, TextDatumGetCString, TopMemoryContext, plperl_proc_desc::trftypes, TRIGGEROID, type_is_rowtype(), TYPEOID, TYPTYPE_PSEUDO, plperl_proc_key::user_id, validate_plperl_function(), and VOIDOID.

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

2706 {
2707  HeapTuple procTup;
2708  Form_pg_proc procStruct;
2709  plperl_proc_key proc_key;
2710  plperl_proc_ptr *proc_ptr;
2711  plperl_proc_desc *volatile prodesc = NULL;
2712  volatile MemoryContext proc_cxt = NULL;
2714  ErrorContextCallback plperl_error_context;
2715 
2716  /* We'll need the pg_proc tuple in any case... */
2717  procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid));
2718  if (!HeapTupleIsValid(procTup))
2719  elog(ERROR, "cache lookup failed for function %u", fn_oid);
2720  procStruct = (Form_pg_proc) GETSTRUCT(procTup);
2721 
2722  /*
2723  * Try to find function in plperl_proc_hash. The reason for this
2724  * overcomplicated-seeming lookup procedure is that we don't know whether
2725  * it's plperl or plperlu, and don't want to spend a lookup in pg_language
2726  * to find out.
2727  */
2728  proc_key.proc_id = fn_oid;
2729  proc_key.is_trigger = is_trigger;
2730  proc_key.user_id = GetUserId();
2731  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2732  HASH_FIND, NULL);
2733  if (validate_plperl_function(proc_ptr, procTup))
2734  {
2735  /* Found valid plperl entry */
2736  ReleaseSysCache(procTup);
2737  return proc_ptr->proc_ptr;
2738  }
2739 
2740  /* If not found or obsolete, maybe it's plperlu */
2741  proc_key.user_id = InvalidOid;
2742  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2743  HASH_FIND, NULL);
2744  if (validate_plperl_function(proc_ptr, procTup))
2745  {
2746  /* Found valid plperlu entry */
2747  ReleaseSysCache(procTup);
2748  return proc_ptr->proc_ptr;
2749  }
2750 
2751  /************************************************************
2752  * If we haven't found it in the hashtable, we analyze
2753  * the function's arguments and return type and store
2754  * the in-/out-functions in the prodesc block,
2755  * then we load the procedure into the Perl interpreter,
2756  * and last we create a new hashtable entry for it.
2757  ************************************************************/
2758 
2759  /* Set a callback for reporting compilation errors */
2760  plperl_error_context.callback = plperl_compile_callback;
2761  plperl_error_context.previous = error_context_stack;
2762  plperl_error_context.arg = NameStr(procStruct->proname);
2763  error_context_stack = &plperl_error_context;
2764 
2765  PG_TRY();
2766  {
2767  HeapTuple langTup;
2768  HeapTuple typeTup;
2769  Form_pg_language langStruct;
2770  Form_pg_type typeStruct;
2771  Datum protrftypes_datum;
2772  Datum prosrcdatum;
2773  bool isnull;
2774  char *proc_source;
2775  MemoryContext oldcontext;
2776 
2777  /************************************************************
2778  * Allocate a context that will hold all PG data for the procedure.
2779  ************************************************************/
2781  NameStr(procStruct->proname),
2783 
2784  /************************************************************
2785  * Allocate and fill a new procedure description block.
2786  * struct prodesc and subsidiary data must all live in proc_cxt.
2787  ************************************************************/
2788  oldcontext = MemoryContextSwitchTo(proc_cxt);
2789  prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc));
2790  prodesc->proname = pstrdup(NameStr(procStruct->proname));
2791  prodesc->fn_cxt = proc_cxt;
2792  prodesc->fn_refcount = 0;
2793  prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data);
2794  prodesc->fn_tid = procTup->t_self;
2795  prodesc->nargs = procStruct->pronargs;
2796  prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo));
2797  prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool));
2798  prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid));
2799  MemoryContextSwitchTo(oldcontext);
2800 
2801  /* Remember if function is STABLE/IMMUTABLE */
2802  prodesc->fn_readonly =
2803  (procStruct->provolatile != PROVOLATILE_VOLATILE);
2804 
2805  /* Fetch protrftypes */
2806  protrftypes_datum = SysCacheGetAttr(PROCOID, procTup,
2807  Anum_pg_proc_protrftypes, &isnull);
2808  MemoryContextSwitchTo(proc_cxt);
2809  prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum);
2810  MemoryContextSwitchTo(oldcontext);
2811 
2812  /************************************************************
2813  * Lookup the pg_language tuple by Oid
2814  ************************************************************/
2815  langTup = SearchSysCache1(LANGOID,
2816  ObjectIdGetDatum(procStruct->prolang));
2817  if (!HeapTupleIsValid(langTup))
2818  elog(ERROR, "cache lookup failed for language %u",
2819  procStruct->prolang);
2820  langStruct = (Form_pg_language) GETSTRUCT(langTup);
2821  prodesc->lang_oid = HeapTupleGetOid(langTup);
2822  prodesc->lanpltrusted = langStruct->lanpltrusted;
2823  ReleaseSysCache(langTup);
2824 
2825  /************************************************************
2826  * Get the required information for input conversion of the
2827  * return value.
2828  ************************************************************/
2829  if (!is_trigger && !is_event_trigger)
2830  {
2831  Oid rettype = procStruct->prorettype;
2832 
2833  typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype));
2834  if (!HeapTupleIsValid(typeTup))
2835  elog(ERROR, "cache lookup failed for type %u", rettype);
2836  typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
2837 
2838  /* Disallow pseudotype result, except VOID or RECORD */
2839  if (typeStruct->typtype == TYPTYPE_PSEUDO)
2840  {
2841  if (rettype == VOIDOID ||
2842  rettype == RECORDOID)
2843  /* okay */ ;
2844  else if (rettype == TRIGGEROID ||
2845  rettype == EVTTRIGGEROID)
2846  ereport(ERROR,
2847  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2848  errmsg("trigger functions can only be called "
2849  "as triggers")));
2850  else
2851  ereport(ERROR,
2852  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2853  errmsg("PL/Perl functions cannot return type %s",
2854  format_type_be(rettype))));
2855  }
2856 
2857  prodesc->result_oid = rettype;
2858  prodesc->fn_retisset = procStruct->proretset;
2859  prodesc->fn_retistuple = type_is_rowtype(rettype);
2860 
2861  prodesc->fn_retisarray =
2862  (typeStruct->typlen == -1 && typeStruct->typelem);
2863 
2864  fmgr_info_cxt(typeStruct->typinput,
2865  &(prodesc->result_in_func),
2866  proc_cxt);
2867  prodesc->result_typioparam = getTypeIOParam(typeTup);
2868 
2869  ReleaseSysCache(typeTup);
2870  }
2871 
2872  /************************************************************
2873  * Get the required information for output conversion
2874  * of all procedure arguments
2875  ************************************************************/
2876  if (!is_trigger && !is_event_trigger)
2877  {
2878  int i;
2879 
2880  for (i = 0; i < prodesc->nargs; i++)
2881  {
2882  Oid argtype = procStruct->proargtypes.values[i];
2883 
2884  typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype));
2885  if (!HeapTupleIsValid(typeTup))
2886  elog(ERROR, "cache lookup failed for type %u", argtype);
2887  typeStruct = (Form_pg_type) GETSTRUCT(typeTup);
2888 
2889  /* Disallow pseudotype argument, except RECORD */
2890  if (typeStruct->typtype == TYPTYPE_PSEUDO &&
2891  argtype != RECORDOID)
2892  ereport(ERROR,
2893  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2894  errmsg("PL/Perl functions cannot accept type %s",
2895  format_type_be(argtype))));
2896 
2897  if (type_is_rowtype(argtype))
2898  prodesc->arg_is_rowtype[i] = true;
2899  else
2900  {
2901  prodesc->arg_is_rowtype[i] = false;
2902  fmgr_info_cxt(typeStruct->typoutput,
2903  &(prodesc->arg_out_func[i]),
2904  proc_cxt);
2905  }
2906 
2907  /* Identify array-type arguments */
2908  if (typeStruct->typelem != 0 && typeStruct->typlen == -1)
2909  prodesc->arg_arraytype[i] = argtype;
2910  else
2911  prodesc->arg_arraytype[i] = InvalidOid;
2912 
2913  ReleaseSysCache(typeTup);
2914  }
2915  }
2916 
2917  /************************************************************
2918  * create the text of the anonymous subroutine.
2919  * we do not use a named subroutine so that we can call directly
2920  * through the reference.
2921  ************************************************************/
2922  prosrcdatum = SysCacheGetAttr(PROCOID, procTup,
2923  Anum_pg_proc_prosrc, &isnull);
2924  if (isnull)
2925  elog(ERROR, "null prosrc");
2926  proc_source = TextDatumGetCString(prosrcdatum);
2927 
2928  /************************************************************
2929  * Create the procedure in the appropriate interpreter
2930  ************************************************************/
2931 
2933 
2934  prodesc->interp = plperl_active_interp;
2935 
2936  plperl_create_sub(prodesc, proc_source, fn_oid);
2937 
2938  activate_interpreter(oldinterp);
2939 
2940  pfree(proc_source);
2941 
2942  if (!prodesc->reference) /* can this happen? */
2943  elog(ERROR, "could not create PL/Perl internal procedure");
2944 
2945  /************************************************************
2946  * OK, link the procedure into the correct hashtable entry.
2947  * Note we assume that the hashtable entry either doesn't exist yet,
2948  * or we already cleared its proc_ptr during the validation attempts
2949  * above. So no need to decrement an old refcount here.
2950  ************************************************************/
2951  proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid;
2952 
2953  proc_ptr = hash_search(plperl_proc_hash, &proc_key,
2954  HASH_ENTER, NULL);
2955  /* We assume these two steps can't throw an error: */
2956  proc_ptr->proc_ptr = prodesc;
2957  increment_prodesc_refcount(prodesc);
2958  }
2959  PG_CATCH();
2960  {
2961  /*
2962  * If we got as far as creating a reference, we should be able to use
2963  * free_plperl_function() to clean up. If not, then at most we have
2964  * some PG memory resources in proc_cxt, which we can just delete.
2965  */
2966  if (prodesc && prodesc->reference)
2967  free_plperl_function(prodesc);
2968  else if (proc_cxt)
2969  MemoryContextDelete(proc_cxt);
2970 
2971  /* Be sure to restore the previous interpreter, too, for luck */
2972  activate_interpreter(oldinterp);
2973 
2974  PG_RE_THROW();
2975  }
2976  PG_END_TRY();
2977 
2978  /* restore previous error callback */
2979  error_context_stack = plperl_error_context.previous;
2980 
2981  ReleaseSysCache(procTup);
2982 
2983  return prodesc;
2984 }
#define NIL
Definition: pg_list.h:69
Definition: fmgr.h:56
static bool validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup)
Definition: plperl.c:2658
List * trftypes
Definition: plperl.c:118
void MemoryContextDelete(MemoryContext context)
Definition: mcxt.c:200
static HTAB * plperl_proc_hash
Definition: plperl.c:231
bool * arg_is_rowtype
Definition: plperl.c:130
#define GETSTRUCT(TUP)
Definition: htup_details.h:661
static void select_perl_context(bool trusted)
Definition: plperl.c:560
Oid GetUserId(void)
Definition: miscinit.c:284
char * pstrdup(const char *in)
Definition: mcxt.c:1076
#define ALLOCSET_SMALL_SIZES
Definition: memutils.h:175
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
#define Anum_pg_proc_prosrc
Definition: pg_proc.h:115
int errcode(int sqlerrcode)
Definition: elog.c:575
MemoryContext fn_cxt
Definition: plperl.c:110
char * format_type_be(Oid type_oid)
Definition: format_type.c:94
#define Anum_pg_proc_protrftypes
Definition: pg_proc.h:114
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
FormData_pg_type * Form_pg_type
Definition: pg_type.h:233
unsigned int Oid
Definition: postgres_ext.h:31
void(* callback)(void *arg)
Definition: elog.h:239
FmgrInfo * arg_out_func
Definition: plperl.c:129
struct ErrorContextCallback * previous
Definition: elog.h:238
HeapTupleHeader t_data
Definition: htup.h:67
ErrorContextCallback * error_context_stack
Definition: elog.c:88
List * oid_array_to_list(Datum datum)
Definition: pg_proc.c:1156
void pfree(void *pointer)
Definition: mcxt.c:949
bool fn_retisset
Definition: plperl.c:121
#define VOIDOID
Definition: pg_type.h:690
#define ObjectIdGetDatum(X)
Definition: postgres.h:513
#define ERROR
Definition: elog.h:43
plperl_proc_desc * proc_ptr
Definition: plperl.c:171
ItemPointerData fn_tid
Definition: plperl.c:113
#define TRIGGEROID
Definition: pg_type.h:692
ItemPointerData t_self
Definition: htup.h:65
FmgrInfo result_in_func
Definition: plperl.c:125
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
#define RECORDOID
Definition: pg_type.h:680
bool type_is_rowtype(Oid typid)
Definition: lsyscache.c:2405
void fmgr_info_cxt(Oid functionId, FmgrInfo *finfo, MemoryContext mcxt)
Definition: fmgr.c:132
#define increment_prodesc_refcount(prodesc)
Definition: plperl.c:134
Oid result_typioparam
Definition: plperl.c:126
#define ereport(elevel, rest)
Definition: elog.h:122
Oid * arg_arraytype
Definition: plperl.c:131
MemoryContext TopMemoryContext
Definition: mcxt.c:43
unsigned long fn_refcount
Definition: plperl.c:111
#define PROVOLATILE_VOLATILE
Definition: pg_proc.h:5539
HeapTuple SearchSysCache1(int cacheId, Datum key1)
Definition: syscache.c:1112
#define TextDatumGetCString(d)
Definition: builtins.h:92
MemoryContext AllocSetContextCreate(MemoryContext parent, const char *name, Size minContextSize, Size initBlockSize, Size maxBlockSize)
Definition: aset.c:322
Oid is_trigger
Definition: plperl.c:164
void * palloc0(Size size)
Definition: mcxt.c:877
uintptr_t Datum
Definition: postgres.h:372
void ReleaseSysCache(HeapTuple tuple)
Definition: syscache.c:1160
Datum SysCacheGetAttr(int cacheId, HeapTuple tup, AttrNumber attributeNumber, bool *isNull)
Definition: syscache.c:1368
static void free_plperl_function(plperl_proc_desc *prodesc)
Definition: plperl.c:2687
FormData_pg_proc * Form_pg_proc
Definition: pg_proc.h:83
#define InvalidOid
Definition: postgres_ext.h:36
bool fn_readonly
Definition: plperl.c:116
#define PG_CATCH()
Definition: elog.h:293
#define HeapTupleIsValid(tuple)
Definition: htup.h:77
#define EVTTRIGGEROID
Definition: pg_type.h:694
SV * reference
Definition: plperl.c:114
#define HeapTupleHeaderGetRawXmin(tup)
Definition: htup_details.h:307
#define PG_RE_THROW()
Definition: elog.h:314
#define TYPTYPE_PSEUDO
Definition: pg_type.h:724
static void plperl_compile_callback(void *arg)
Definition: plperl.c:4055
FormData_pg_language * Form_pg_language
Definition: pg_language.h:51
int errmsg(const char *fmt,...)
Definition: elog.c:797
bool fn_retistuple
Definition: plperl.c:120
int i
Oid getTypeIOParam(HeapTuple typeTuple)
Definition: lsyscache.c:2053
#define NameStr(name)
Definition: c.h:547
static void plperl_create_sub(plperl_proc_desc *desc, const char *s, Oid fn_oid)
Definition: plperl.c:2086
char * proname
Definition: plperl.c:109
TransactionId fn_xmin
Definition: plperl.c:112
#define elog
Definition: elog.h:219
#define HeapTupleGetOid(tuple)
Definition: htup_details.h:700
#define PG_TRY()
Definition: elog.h:284
plperl_interp_desc * interp
Definition: plperl.c:115
#define PG_END_TRY()
Definition: elog.h:300
bool lanpltrusted
Definition: plperl.c:119
bool fn_retisarray
Definition: plperl.c:122

◆ free_plperl_function()

static void free_plperl_function ( plperl_proc_desc prodesc)
static

Definition at line 2687 of file plperl.c.

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().

2688 {
2689  Assert(prodesc->fn_refcount == 0);
2690  /* Release CODE reference, if we have one, from the appropriate interp */
2691  if (prodesc->reference)
2692  {
2694 
2695  activate_interpreter(prodesc->interp);
2696  SvREFCNT_dec_current(prodesc->reference);
2697  activate_interpreter(oldinterp);
2698  }
2699  /* Release all PG-owned data for this proc */
2700  MemoryContextDelete(prodesc->fn_cxt);
2701 }
void MemoryContextDelete(MemoryContext context)
Definition: mcxt.c:200
MemoryContext fn_cxt
Definition: plperl.c:110
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
unsigned long fn_refcount
Definition: plperl.c:111
static void SvREFCNT_dec_current(SV *sv)
Definition: plperl.c:317
#define Assert(condition)
Definition: c.h:670
SV * reference
Definition: plperl.c:114
plperl_interp_desc * interp
Definition: plperl.c:115

◆ get_perl_array_ref()

static SV * get_perl_array_ref ( SV *  sv)
static

Definition at line 1146 of file plperl.c.

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

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

1147 {
1148  dTHX;
1149 
1150  if (SvOK(sv) && SvROK(sv))
1151  {
1152  if (SvTYPE(SvRV(sv)) == SVt_PVAV)
1153  return sv;
1154  else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY"))
1155  {
1156  HV *hv = (HV *) SvRV(sv);
1157  SV **sav = hv_fetch_string(hv, "array");
1158 
1159  if (*sav && SvOK(*sav) && SvROK(*sav) &&
1160  SvTYPE(SvRV(*sav)) == SVt_PVAV)
1161  return *sav;
1162 
1163  elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
1164  }
1165  }
1166  return NULL;
1167 }
#define dTHX
Definition: ppport.h:3208
static SV ** hv_fetch_string(HV *hv, const char *key)
Definition: plperl.c:4020
#define ERROR
Definition: elog.h:43
#define elog
Definition: elog.h:219

◆ hek2cstr()

static char * hek2cstr ( HE *  he)
static

Definition at line 328 of file plperl.c.

References dTHX, HeUTF8, and sv2cstr().

Referenced by plperl_build_tuple_result(), and plperl_modify_tuple().

329 {
330  dTHX;
331  char *ret;
332  SV *sv;
333 
334  /*
335  * HeSVKEY_force will return a temporary mortal SV*, so we need to make
336  * sure to free it with ENTER/SAVE/FREE/LEAVE
337  */
338  ENTER;
339  SAVETMPS;
340 
341  /*-------------------------
342  * Unfortunately, while HeUTF8 is true for most things > 256, for values
343  * 128..255 it's not, but perl will treat them as unicode code points if
344  * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode
345  * for more)
346  *
347  * So if we did the expected:
348  * if (HeUTF8(he))
349  * utf_u2e(key...);
350  * else // must be ascii
351  * return HePV(he);
352  * we won't match columns with codepoints from 128..255
353  *
354  * For a more concrete example given a column with the name of the unicode
355  * codepoint U+00ae (registered sign) and a UTF8 database and the perl
356  * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns
357  * 0 and HePV() would give us a char * with 1 byte contains the decimal
358  * value 174
359  *
360  * Perl has the brains to know when it should utf8 encode 174 properly, so
361  * here we force it into an SV so that perl will figure it out and do the
362  * right thing
363  *-------------------------
364  */
365 
366  sv = HeSVKEY_force(he);
367  if (HeUTF8(he))
368  SvUTF8_on(sv);
369  ret = sv2cstr(sv);
370 
371  /* free sv */
372  FREETMPS;
373  LEAVE;
374 
375  return ret;
376 }
#define HeUTF8(he)
Definition: plperl.h:93
#define dTHX
Definition: ppport.h:3208
static char * sv2cstr(SV *sv)

◆ hv_fetch_string()

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

Definition at line 4020 of file plperl.c.

References dTHX, pfree(), pg_server_to_any(), and PG_UTF8.

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

4021 {
4022  dTHX;
4023  int32 hlen;
4024  char *hkey;
4025  SV **ret;
4026 
4027  hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
4028 
4029  /* See notes in hv_store_string */
4030  hlen = -(int) strlen(hkey);
4031  ret = hv_fetch(hv, hkey, hlen, 0);
4032 
4033  if (hkey != key)
4034  pfree(hkey);
4035 
4036  return ret;
4037 }
#define dTHX
Definition: ppport.h:3208
char * pg_server_to_any(const char *s, int len, int encoding)
Definition: mbutils.c:634
signed int int32
Definition: c.h:284
void pfree(void *pointer)
Definition: mcxt.c:949

◆ hv_store_string()

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

Definition at line 3993 of file plperl.c.

References dTHX, pfree(), pg_server_to_any(), and PG_UTF8.

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

3994 {
3995  dTHX;
3996  int32 hlen;
3997  char *hkey;
3998  SV **ret;
3999 
4000  hkey = pg_server_to_any(key, strlen(key), PG_UTF8);
4001 
4002  /*
4003  * hv_store() recognizes a negative klen parameter as meaning a UTF-8
4004  * encoded key.
4005  */
4006  hlen = -(int) strlen(hkey);
4007  ret = hv_store(hv, hkey, hlen, val, 0);
4008 
4009  if (hkey != key)
4010  pfree(hkey);
4011 
4012  return ret;
4013 }
#define dTHX
Definition: ppport.h:3208
char * pg_server_to_any(const char *s, int len, int encoding)
Definition: mbutils.c:634
signed int int32
Definition: c.h:284
void pfree(void *pointer)
Definition: mcxt.c:949
long val
Definition: informix.c:689

◆ make_array_ref()

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

Definition at line 1581 of file plperl.c.

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().

1582 {
1583  dTHX;
1584  int i;
1585  AV *result = newAV();
1586 
1587  for (i = first; i < last; i++)
1588  {
1589  if (info->nulls[i])
1590  {
1591  /*
1592  * We can't use &PL_sv_undef here. See "AVs, HVs and undefined
1593  * values" in perlguts.
1594  */
1595  av_push(result, newSV(0));
1596  }
1597  else
1598  {
1599  Datum itemvalue = info->elements[i];
1600 
1601  if (info->transform_proc.fn_oid)
1602  av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue)));
1603  else if (info->elem_is_rowtype)
1604  /* Handle composite type elements */
1605  av_push(result, plperl_hash_from_datum(itemvalue));
1606  else
1607  {
1608  char *val = OutputFunctionCall(&info->proc, itemvalue);
1609 
1610  av_push(result, cstr2sv(val));
1611  }
1612  }
1613  }
1614  return newRV_noinc((SV *) result);
1615 }
FmgrInfo transform_proc
Definition: plperl.c:223
#define dTHX
Definition: ppport.h:3208
static SV * plperl_hash_from_datum(Datum attr)
Definition: plperl.c:2988
char * OutputFunctionCall(FmgrInfo *flinfo, Datum val)
Definition: fmgr.c:1662
#define newRV_noinc(a)
Definition: ppport.h:4456
uintptr_t Datum
Definition: postgres.h:372
bool elem_is_rowtype
Definition: plperl.c:218
static SV * cstr2sv(const char *str)
Oid fn_oid
Definition: fmgr.h:59
FmgrInfo proc
Definition: plperl.c:222
#define DatumGetPointer(X)
Definition: postgres.h:555
bool * nulls
Definition: plperl.c:220
int i
Datum * elements
Definition: plperl.c:219
#define FunctionCall1(flinfo, arg1)
Definition: fmgr.h:603
long val
Definition: informix.c:689

◆ PG_FUNCTION_INFO_V1() [1/6]

◆ 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 1248 of file plperl.c.

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

Referenced by plperl_sv_to_datum().

1249 {
1250  dTHX;
1251  ArrayBuildState *astate;
1252  Oid elemtypid;
1253  FmgrInfo finfo;
1254  Oid typioparam;
1255  int dims[MAXDIM];
1256  int lbs[MAXDIM];
1257  int ndims = 1;
1258  int i;
1259 
1260  elemtypid = get_element_type(typid);
1261  if (!elemtypid)
1262  ereport(ERROR,
1263  (errcode(ERRCODE_DATATYPE_MISMATCH),
1264  errmsg("cannot convert Perl array to non-array type %s",
1265  format_type_be(typid))));
1266 
1267  astate = initArrayResult(elemtypid, CurrentMemoryContext, true);
1268 
1269  _sv_to_datum_finfo(elemtypid, &finfo, &typioparam);
1270 
1271  memset(dims, 0, sizeof(dims));
1272  dims[0] = av_len((AV *) SvRV(src)) + 1;
1273 
1274  array_to_datum_internal((AV *) SvRV(src), astate,
1275  &ndims, dims, 1,
1276  typid, elemtypid, typmod,
1277  &finfo, typioparam);
1278 
1279  /* ensure we get zero-D array for no inputs, as per PG convention */
1280  if (dims[0] <= 0)
1281  ndims = 0;
1282 
1283  for (i = 0; i < ndims; i++)
1284  lbs[i] = 1;
1285 
1286  return makeMdArrayResult(astate, ndims, dims, lbs,
1287  CurrentMemoryContext, true);
1288 }
Datum makeMdArrayResult(ArrayBuildState *astate, int ndims, int *dims, int *lbs, MemoryContext rcontext, bool release)
Definition: arrayfuncs.c:5138
Definition: fmgr.h:56
ArrayBuildState * initArrayResult(Oid element_type, MemoryContext rcontext, bool subcontext)
Definition: arrayfuncs.c:5003
#define dTHX
Definition: ppport.h:3208
#define MAXDIM
Definition: c.h:467
Oid get_element_type(Oid typid)
Definition: lsyscache.c:2498
int errcode(int sqlerrcode)
Definition: elog.c:575
char * format_type_be(Oid type_oid)
Definition: format_type.c:94
unsigned int Oid
Definition: postgres_ext.h:31
#define ERROR
Definition: elog.h:43
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
#define ereport(elevel, rest)
Definition: elog.h:122
int errmsg(const char *fmt,...)
Definition: elog.c:797
int i
static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
Definition: plperl.c:1292
static void array_to_datum_internal(AV *av, ArrayBuildState *astate, int *ndims, int *dims, int cur_depth, Oid arraytypid, Oid elemtypid, int32 typmod, FmgrInfo *finfo, Oid typioparam)
Definition: plperl.c:1173

◆ plperl_build_tuple_result()

static HeapTuple plperl_build_tuple_result ( HV *  perlhash,
TupleDesc  td 
)
static

Definition at line 1083 of file plperl.c.

References dTHX, ereport, errcode(), errmsg(), ERROR, heap_form_tuple(), hek2cstr(), InvalidOid, tupleDesc::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().

1084 {
1085  dTHX;
1086  Datum *values;
1087  bool *nulls;
1088  HE *he;
1089  HeapTuple tup;
1090 
1091  values = palloc0(sizeof(Datum) * td->natts);
1092  nulls = palloc(sizeof(bool) * td->natts);
1093  memset(nulls, true, sizeof(bool) * td->natts);
1094 
1095  hv_iterinit(perlhash);
1096  while ((he = hv_iternext(perlhash)))
1097  {
1098  SV *val = HeVAL(he);
1099  char *key = hek2cstr(he);
1100  int attn = SPI_fnumber(td, key);
1101  Form_pg_attribute attr = TupleDescAttr(td, attn - 1);
1102 
1103  if (attn == SPI_ERROR_NOATTRIBUTE)
1104  ereport(ERROR,
1105  (errcode(ERRCODE_UNDEFINED_COLUMN),
1106  errmsg("Perl hash contains nonexistent column \"%s\"",
1107  key)));
1108  if (attn <= 0)
1109  ereport(ERROR,
1110  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1111  errmsg("cannot set system attribute \"%s\"",
1112  key)));
1113 
1114  values[attn - 1] = plperl_sv_to_datum(val,
1115  attr->atttypid,
1116  attr->atttypmod,
1117  NULL,
1118  NULL,
1119  InvalidOid,
1120  &nulls[attn - 1]);
1121 
1122  pfree(key);
1123  }
1124  hv_iterinit(perlhash);
1125 
1126  tup = heap_form_tuple(td, values, nulls);
1127  pfree(values);
1128  pfree(nulls);
1129  return tup;
1130 }
int SPI_fnumber(TupleDesc tupdesc, const char *fname)
Definition: spi.c:767
static char * hek2cstr(HE *he)
Definition: plperl.c:328
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
#define dTHX
Definition: ppport.h:3208
#define TupleDescAttr(tupdesc, i)
Definition: tupdesc.h:90
int errcode(int sqlerrcode)
Definition: elog.c:575
HeapTuple heap_form_tuple(TupleDesc tupleDescriptor, Datum *values, bool *isnull)
Definition: heaptuple.c:695
int natts
Definition: tupdesc.h:79
void pfree(void *pointer)
Definition: mcxt.c:949
#define ERROR
Definition: elog.h:43
#define SPI_ERROR_NOATTRIBUTE
Definition: spi.h:44
FormData_pg_attribute * Form_pg_attribute
Definition: pg_attribute.h:187
#define ereport(elevel, rest)
Definition: elog.h:122
void * palloc0(Size size)
Definition: mcxt.c:877
uintptr_t Datum
Definition: postgres.h:372
#define InvalidOid
Definition: postgres_ext.h:36
static Datum values[MAXATTR]
Definition: bootstrap.c:164
void * palloc(Size size)
Definition: mcxt.c:848
int errmsg(const char *fmt,...)
Definition: elog.c:797
long val
Definition: informix.c:689

◆ plperl_call_handler()

Datum plperl_call_handler ( PG_FUNCTION_ARGS  )

Definition at line 1829 of file plperl.c.

References activate_interpreter(), CALLED_AS_EVENT_TRIGGER, CALLED_AS_TRIGGER, current_call_data, decrement_prodesc_refcount, plperl_call_data::fcinfo, MemSet, PG_CATCH, PG_END_TRY, PG_FUNCTION_INFO_V1(), PG_RE_THROW, PG_TRY, plperl_active_interp, plperl_event_trigger_handler(), plperl_func_handler(), plperl_inline_handler(), plperl_trigger_handler(), PointerGetDatum, and plperl_call_data::prodesc.

Referenced by plperl_modify_tuple(), and plperlu_call_handler().

1830 {
1831  Datum retval;
1832  plperl_call_data *volatile save_call_data = current_call_data;
1833  plperl_interp_desc *volatile oldinterp = plperl_active_interp;
1834  plperl_call_data this_call_data;
1835 
1836  /* Initialize current-call status record */
1837  MemSet(&this_call_data, 0, sizeof(this_call_data));
1838  this_call_data.fcinfo = fcinfo;
1839 
1840  PG_TRY();
1841  {
1842  current_call_data = &this_call_data;
1843  if (CALLED_AS_TRIGGER(fcinfo))
1844  retval = PointerGetDatum(plperl_trigger_handler(fcinfo));
1845  else if (CALLED_AS_EVENT_TRIGGER(fcinfo))
1846  {
1848  retval = (Datum) 0;
1849  }
1850  else
1851  retval = plperl_func_handler(fcinfo);
1852  }
1853  PG_CATCH();
1854  {
1855  current_call_data = save_call_data;
1856  activate_interpreter(oldinterp);
1857  if (this_call_data.prodesc)
1858  decrement_prodesc_refcount(this_call_data.prodesc);
1859  PG_RE_THROW();
1860  }
1861  PG_END_TRY();
1862 
1863  current_call_data = save_call_data;
1864  activate_interpreter(oldinterp);
1865  if (this_call_data.prodesc)
1866  decrement_prodesc_refcount(this_call_data.prodesc);
1867  return retval;
1868 }
#define CALLED_AS_EVENT_TRIGGER(fcinfo)
Definition: event_trigger.h:40
static Datum plperl_func_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2397
#define decrement_prodesc_refcount(prodesc)
Definition: plperl.c:136
FunctionCallInfo fcinfo
Definition: plperl.c:181
#define PointerGetDatum(X)
Definition: postgres.h:562
#define MemSet(start, val, len)
Definition: c.h:853
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
static void plperl_event_trigger_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2621
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS)
Definition: plperl.c:2508
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
uintptr_t Datum
Definition: postgres.h:372
#define PG_CATCH()
Definition: elog.h:293
#define CALLED_AS_TRIGGER(fcinfo)
Definition: trigger.h:25
#define PG_RE_THROW()
Definition: elog.h:314
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define PG_TRY()
Definition: elog.h:284
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define PG_END_TRY()
Definition: elog.h:300

◆ 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 2334 of file plperl.c.

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

Referenced by plperl_event_trigger_handler().

2337 {
2338  dTHX;
2339  dSP;
2340  SV *retval,
2341  *TDsv;
2342  int count;
2343 
2344  ENTER;
2345  SAVETMPS;
2346 
2347  TDsv = get_sv("main::_TD", 0);
2348  if (!TDsv)
2349  ereport(ERROR,
2350  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2351  errmsg("couldn't fetch $_TD")));
2352 
2353  save_item(TDsv); /* local $_TD */
2354  sv_setsv(TDsv, td);
2355 
2356  PUSHMARK(sp);
2357  PUTBACK;
2358 
2359  /* Do NOT use G_KEEPERR here */
2360  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2361 
2362  SPAGAIN;
2363 
2364  if (count != 1)
2365  {
2366  PUTBACK;
2367  FREETMPS;
2368  LEAVE;
2369  ereport(ERROR,
2370  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2371  errmsg("didn't get a return item from trigger function")));
2372  }
2373 
2374  if (SvTRUE(ERRSV))
2375  {
2376  (void) POPs;
2377  PUTBACK;
2378  FREETMPS;
2379  LEAVE;
2380  /* XXX need to find a way to determine a better errcode here */
2381  ereport(ERROR,
2382  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2384  }
2385 
2386  retval = newSVsv(POPs);
2387  (void) retval; /* silence compiler warning */
2388 
2389  PUTBACK;
2390  FREETMPS;
2391  LEAVE;
2392 
2393  return;
2394 }
#define dTHX
Definition: ppport.h:3208
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
#define ERROR
Definition: elog.h:43
#define ereport(elevel, rest)
Definition: elog.h:122
SV * reference
Definition: plperl.c:114
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1069
int errmsg(const char *fmt,...)
Definition: elog.c:797
#define get_sv
Definition: ppport.h:3878
static char * sv2cstr(SV *sv)

◆ plperl_call_perl_func()

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

Definition at line 2173 of file plperl.c.

References FunctionCallInfoData::arg, plperl_proc_desc::arg_arraytype, plperl_proc_desc::arg_is_rowtype, plperl_proc_desc::arg_out_func, FunctionCallInfoData::argnull, Assert, cstr2sv(), DatumGetPointer, dTHX, ereport, errcode(), errmsg(), ERROR, ERRSV, FunctionCallInfoData::flinfo, FmgrInfo::fn_oid, get_func_signature(), get_transform_fromsql(), i, 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(), and plperl_proc_desc::trftypes.

Referenced by plperl_func_handler(), and plperl_inline_handler().

2174 {
2175  dTHX;
2176  dSP;
2177  SV *retval;
2178  int i;
2179  int count;
2180  Oid *argtypes = NULL;
2181  int nargs = 0;
2182 
2183  ENTER;
2184  SAVETMPS;
2185 
2186  PUSHMARK(SP);
2187  EXTEND(sp, desc->nargs);
2188 
2189  /* Get signature for true functions; inline blocks have no args. */
2190  if (fcinfo->flinfo->fn_oid)
2191  get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs);
2192  Assert(nargs == desc->nargs);
2193 
2194  for (i = 0; i < desc->nargs; i++)
2195  {
2196  if (fcinfo->argnull[i])
2197  PUSHs(&PL_sv_undef);
2198  else if (desc->arg_is_rowtype[i])
2199  {
2200  SV *sv = plperl_hash_from_datum(fcinfo->arg[i]);
2201 
2202  PUSHs(sv_2mortal(sv));
2203  }
2204  else
2205  {
2206  SV *sv;
2207  Oid funcid;
2208 
2209  if (OidIsValid(desc->arg_arraytype[i]))
2210  sv = plperl_ref_from_pg_array(fcinfo->arg[i], desc->arg_arraytype[i]);
2212  sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->arg[i]));
2213  else
2214  {
2215  char *tmp;
2216 
2217  tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
2218  fcinfo->arg[i]);
2219  sv = cstr2sv(tmp);
2220  pfree(tmp);
2221  }
2222 
2223  PUSHs(sv_2mortal(sv));
2224  }
2225  }
2226  PUTBACK;
2227 
2228  /* Do NOT use G_KEEPERR here */
2229  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2230 
2231  SPAGAIN;
2232 
2233  if (count != 1)
2234  {
2235  PUTBACK;
2236  FREETMPS;
2237  LEAVE;
2238  ereport(ERROR,
2239  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2240  errmsg("didn't get a return item from function")));
2241  }
2242 
2243  if (SvTRUE(ERRSV))
2244  {
2245  (void) POPs;
2246  PUTBACK;
2247  FREETMPS;
2248  LEAVE;
2249  /* XXX need to find a way to determine a better errcode here */
2250  ereport(ERROR,
2251  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2253  }
2254 
2255  retval = newSVsv(POPs);
2256 
2257  PUTBACK;
2258  FREETMPS;
2259  LEAVE;
2260 
2261  return retval;
2262 }
static SV * plperl_ref_from_pg_array(Datum arg, Oid typid)
Definition: plperl.c:1468
Oid get_transform_fromsql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1872
List * trftypes
Definition: plperl.c:118
bool * arg_is_rowtype
Definition: plperl.c:130
#define dTHX
Definition: ppport.h:3208
Oid get_func_signature(Oid funcid, Oid **argtypes, int *nargs)
Definition: lsyscache.c:1500
#define PL_sv_undef
Definition: ppport.h:4129
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
static SV * plperl_hash_from_datum(Datum attr)
Definition: plperl.c:2988
unsigned int Oid
Definition: postgres_ext.h:31
FmgrInfo * arg_out_func
Definition: plperl.c:129
#define OidIsValid(objectId)
Definition: c.h:576
char * OutputFunctionCall(FmgrInfo *flinfo, Datum val)
Definition: fmgr.c:1662
FmgrInfo * flinfo
Definition: fmgr.h:79
void pfree(void *pointer)
Definition: mcxt.c:949
#define ERROR
Definition: elog.h:43
#define OidFunctionCall1(functionId, arg1)
Definition: fmgr.h:623
bool argnull[FUNC_MAX_ARGS]
Definition: fmgr.h:86
#define ereport(elevel, rest)
Definition: elog.h:122
Oid * arg_arraytype
Definition: plperl.c:131
static SV * cstr2sv(const char *str)
Oid fn_oid
Definition: fmgr.h:59
Datum arg[FUNC_MAX_ARGS]
Definition: fmgr.h:85
#define Assert(condition)
Definition: c.h:670
SV * reference
Definition: plperl.c:114
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1069
#define DatumGetPointer(X)
Definition: postgres.h:555
int errmsg(const char *fmt,...)
Definition: elog.c:797
int i
plperl_proc_desc * prodesc
Definition: plperl.c:180
static plperl_call_data * current_call_data
Definition: plperl.c:248
static char * sv2cstr(SV *sv)

◆ plperl_call_perl_trigger_func()

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

Definition at line 2266 of file plperl.c.

References FunctionCallInfoData::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().

2268 {
2269  dTHX;
2270  dSP;
2271  SV *retval,
2272  *TDsv;
2273  int i,
2274  count;
2275  Trigger *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger;
2276 
2277  ENTER;
2278  SAVETMPS;
2279 
2280  TDsv = get_sv("main::_TD", 0);
2281  if (!TDsv)
2282  ereport(ERROR,
2283  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2284  errmsg("couldn't fetch $_TD")));
2285 
2286  save_item(TDsv); /* local $_TD */
2287  sv_setsv(TDsv, td);
2288 
2289  PUSHMARK(sp);
2290  EXTEND(sp, tg_trigger->tgnargs);
2291 
2292  for (i = 0; i < tg_trigger->tgnargs; i++)
2293  PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i])));
2294  PUTBACK;
2295 
2296  /* Do NOT use G_KEEPERR here */
2297  count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL);
2298 
2299  SPAGAIN;
2300 
2301  if (count != 1)
2302  {
2303  PUTBACK;
2304  FREETMPS;
2305  LEAVE;
2306  ereport(ERROR,
2307  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2308  errmsg("didn't get a return item from trigger function")));
2309  }
2310 
2311  if (SvTRUE(ERRSV))
2312  {
2313  (void) POPs;
2314  PUTBACK;
2315  FREETMPS;
2316  LEAVE;
2317  /* XXX need to find a way to determine a better errcode here */
2318  ereport(ERROR,
2319  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
2321  }
2322 
2323  retval = newSVsv(POPs);
2324 
2325  PUTBACK;
2326  FREETMPS;
2327  LEAVE;
2328 
2329  return retval;
2330 }
#define dTHX
Definition: ppport.h:3208
fmNodePtr context
Definition: fmgr.h:80
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
#define ERROR
Definition: elog.h:43
#define ereport(elevel, rest)
Definition: elog.h:122
char ** tgargs
Definition: reltrigger.h:40
static SV * cstr2sv(const char *str)
SV * reference
Definition: plperl.c:114
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1069
int errmsg(const char *fmt,...)
Definition: elog.c:797
#define get_sv
Definition: ppport.h:3878
int i
int16 tgnargs
Definition: reltrigger.h:37
static char * sv2cstr(SV *sv)

◆ plperl_compile_callback()

static void plperl_compile_callback ( void *  arg)
static

Definition at line 4055 of file plperl.c.

References errcontext.

Referenced by compile_plperl_function().

4056 {
4057  char *procname = (char *) arg;
4058 
4059  if (procname)
4060  errcontext("compilation of PL/Perl function \"%s\"", procname);
4061 }
#define errcontext
Definition: elog.h:164
void * arg

◆ plperl_create_sub()

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

Definition at line 2086 of file plperl.c.

References 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, strip_trailing_ws(), and sv2cstr().

Referenced by compile_plperl_function(), and plperl_inline_handler().

2087 {
2088  dTHX;
2089  dSP;
2090  char subname[NAMEDATALEN + 40];
2091  HV *pragma_hv = newHV();
2092  SV *subref = NULL;
2093  int count;
2094 
2095  sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
2096 
2097  if (plperl_use_strict)
2098  hv_store_string(pragma_hv, "strict", (SV *) newAV());
2099 
2100  ENTER;
2101  SAVETMPS;
2102  PUSHMARK(SP);
2103  EXTEND(SP, 4);
2104  PUSHs(sv_2mortal(cstr2sv(subname)));
2105  PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv)));
2106 
2107  /*
2108  * Use 'false' for $prolog in mkfunc, which is kept for compatibility in
2109  * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function
2110  * compiler.
2111  */
2112  PUSHs(&PL_sv_no);
2113  PUSHs(sv_2mortal(cstr2sv(s)));
2114  PUTBACK;
2115 
2116  /*
2117  * G_KEEPERR seems to be needed here, else we don't recognize compile
2118  * errors properly. Perhaps it's because there's another level of eval
2119  * inside mksafefunc?
2120  */
2121  count = perl_call_pv("PostgreSQL::InServer::mkfunc",
2122  G_SCALAR | G_EVAL | G_KEEPERR);
2123  SPAGAIN;
2124 
2125  if (count == 1)
2126  {
2127  SV *sub_rv = (SV *) POPs;
2128 
2129  if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV)
2130  {
2131  subref = newRV_inc(SvRV(sub_rv));
2132  }
2133  }
2134 
2135  PUTBACK;
2136  FREETMPS;
2137  LEAVE;
2138 
2139  if (SvTRUE(ERRSV))
2140  ereport(ERROR,
2141  (errcode(ERRCODE_SYNTAX_ERROR),
2143 
2144  if (!subref)
2145  ereport(ERROR,
2146  (errcode(ERRCODE_SYNTAX_ERROR),
2147  errmsg("didn't get a CODE reference from compiling function \"%s\"",
2148  prodesc->proname)));
2149 
2150  prodesc->reference = subref;
2151 
2152  return;
2153 }
#define dTHX
Definition: ppport.h:3208
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3993
#define NAMEDATALEN
#define ERROR
Definition: elog.h:43
#define ereport(elevel, rest)
Definition: elog.h:122
#define newRV_noinc(a)
Definition: ppport.h:4456
#define newRV_inc(sv)
Definition: ppport.h:4442
static SV * cstr2sv(const char *str)
static bool plperl_use_strict
Definition: plperl.c:238
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1069
int errmsg(const char *fmt,...)
Definition: elog.c:797
#define PL_sv_no
Definition: ppport.h:4128
static char * sv2cstr(SV *sv)

◆ plperl_destroy_interp()

static void plperl_destroy_interp ( PerlInterpreter **  interp)
static

Definition at line 926 of file plperl.c.

References dTHX, and PERL_UNUSED_VAR.

Referenced by plperl_fini().

927 {
928  if (interp && *interp)
929  {
930  /*
931  * Only a very minimal destruction is performed: - just call END
932  * blocks.
933  *
934  * We could call perl_destruct() but we'd need to audit its actions
935  * very carefully and work-around any that impact us. (Calling
936  * sv_clean_objs() isn't an option because it's not part of perl's
937  * public API so isn't portably available.) Meanwhile END blocks can
938  * be used to perform manual cleanup.
939  */
940  dTHX;
941 
942  /* Run END blocks - based on perl's perl_destruct() */
943  if (PL_exit_flags & PERL_EXIT_DESTRUCT_END)
944  {
945  dJMPENV;
946  int x = 0;
947 
948  JMPENV_PUSH(x);
949  PERL_UNUSED_VAR(x);
950  if (PL_endav && !PL_minus_c)
951  call_list(PL_scopestack_ix, PL_endav);
952  JMPENV_POP;
953  }
954  LEAVE;
955  FREETMPS;
956 
957  *interp = NULL;
958  }
959 }
#define dTHX
Definition: ppport.h:3208
#define PERL_UNUSED_VAR(x)
Definition: ppport.h:3730

◆ plperl_event_trigger_build_args()

static SV* plperl_event_trigger_build_args ( FunctionCallInfo  fcinfo)
static

Definition at line 1726 of file plperl.c.

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

Referenced by plperl_event_trigger_handler().

1727 {
1728  dTHX;
1729  EventTriggerData *tdata;
1730  HV *hv;
1731 
1732  hv = newHV();
1733 
1734  tdata = (EventTriggerData *) fcinfo->context;
1735 
1736  hv_store_string(hv, "event", cstr2sv(tdata->event));
1737  hv_store_string(hv, "tag", cstr2sv(tdata->tag));
1738 
1739  return newRV_noinc((SV *) hv);
1740 }
#define dTHX
Definition: ppport.h:3208
fmNodePtr context
Definition: fmgr.h:80
const char * tag
Definition: event_trigger.h:28
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3993
const char * event
Definition: event_trigger.h:26
#define newRV_noinc(a)
Definition: ppport.h:4456
static SV * cstr2sv(const char *str)

◆ plperl_event_trigger_handler()

static void plperl_event_trigger_handler ( PG_FUNCTION_ARGS  )
static

Definition at line 2621 of file plperl.c.

References activate_interpreter(), ErrorContextCallback::arg, ErrorContextCallback::callback, compile_plperl_function(), 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().

2622 {
2623  plperl_proc_desc *prodesc;
2624  SV *svTD;
2625  ErrorContextCallback pl_error_context;
2626 
2627  /* Connect to SPI manager */
2628  if (SPI_connect() != SPI_OK_CONNECT)
2629  elog(ERROR, "could not connect to SPI manager");
2630 
2631  /* Find or compile the function */
2632  prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true);
2633  current_call_data->prodesc = prodesc;
2634  increment_prodesc_refcount(prodesc);
2635 
2636  /* Set a callback for error reporting */
2637  pl_error_context.callback = plperl_exec_callback;
2638  pl_error_context.previous = error_context_stack;
2639  pl_error_context.arg = prodesc->proname;
2640  error_context_stack = &pl_error_context;
2641 
2642  activate_interpreter(prodesc->interp);
2643 
2644  svTD = plperl_event_trigger_build_args(fcinfo);
2645  plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD);
2646 
2647  if (SPI_finish() != SPI_OK_FINISH)
2648  elog(ERROR, "SPI_finish() failed");
2649 
2650  /* Restore the previous error callback */
2651  error_context_stack = pl_error_context.previous;
2652 
2653  SvREFCNT_dec_current(svTD);
2654 }
#define SPI_OK_CONNECT
Definition: spi.h:50
int SPI_connect(void)
Definition: spi.c:84
int SPI_finish(void)
Definition: spi.c:149
void(* callback)(void *arg)
Definition: elog.h:239
struct ErrorContextCallback * previous
Definition: elog.h:238
static void plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, SV *td)
Definition: plperl.c:2334
ErrorContextCallback * error_context_stack
Definition: elog.c:88
#define ERROR
Definition: elog.h:43
static plperl_proc_desc * compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
Definition: plperl.c:2705
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
static void plperl_exec_callback(void *arg)
Definition: plperl.c:4043
#define increment_prodesc_refcount(prodesc)
Definition: plperl.c:134
static void SvREFCNT_dec_current(SV *sv)
Definition: plperl.c:317
#define SPI_OK_FINISH
Definition: spi.h:51
static SV * plperl_event_trigger_build_args(FunctionCallInfo fcinfo)
Definition: plperl.c:1726
char * proname
Definition: plperl.c:109
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
plperl_interp_desc * interp
Definition: plperl.c:115
static plperl_call_data * current_call_data
Definition: plperl.c:248

◆ plperl_exec_callback()

static void plperl_exec_callback ( void *  arg)
static

Definition at line 4043 of file plperl.c.

References errcontext.

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

4044 {
4045  char *procname = (char *) arg;
4046 
4047  if (procname)
4048  errcontext("PL/Perl function \"%s\"", procname);
4049 }
#define errcontext
Definition: elog.h:164
void * arg

◆ plperl_fini()

static void plperl_fini ( int  code,
Datum  arg 
)
static

Definition at line 516 of file plperl.c.

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

Referenced by select_perl_context().

517 {
518  HASH_SEQ_STATUS hash_seq;
519  plperl_interp_desc *interp_desc;
520 
521  elog(DEBUG3, "plperl_fini");
522 
523  /*
524  * Indicate that perl is terminating. Disables use of spi_* functions when
525  * running END/DESTROY code. See check_spi_usage_allowed(). Could be
526  * enabled in future, with care, using a transaction
527  * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
528  */
529  plperl_ending = true;
530 
531  /* Only perform perl cleanup if we're exiting cleanly */
532  if (code)
533  {
534  elog(DEBUG3, "plperl_fini: skipped");
535  return;
536  }
537 
538  /* Zap the "held" interpreter, if we still have it */
540 
541  /* Zap any fully-initialized interpreters */
542  hash_seq_init(&hash_seq, plperl_interp_hash);
543  while ((interp_desc = hash_seq_search(&hash_seq)) != NULL)
544  {
545  if (interp_desc->interp)
546  {
547  activate_interpreter(interp_desc);
548  plperl_destroy_interp(&interp_desc->interp);
549  }
550  }
551 
552  elog(DEBUG3, "plperl_fini: done");
553 }
static bool plperl_ending
Definition: plperl.c:243
#define DEBUG3
Definition: elog.h:23
PerlInterpreter * interp
Definition: plperl.c:93
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
static void plperl_destroy_interp(PerlInterpreter **)
Definition: plperl.c:926
void * hash_seq_search(HASH_SEQ_STATUS *status)
Definition: dynahash.c:1385
void hash_seq_init(HASH_SEQ_STATUS *status, HTAB *hashp)
Definition: dynahash.c:1375
static PerlInterpreter * plperl_held_interp
Definition: plperl.c:235
static HTAB * plperl_interp_hash
Definition: plperl.c:230
#define elog
Definition: elog.h:219

◆ plperl_func_handler()

static Datum plperl_func_handler ( PG_FUNCTION_ARGS  )
static

Definition at line 2397 of file plperl.c.

References activate_interpreter(), ReturnSetInfo::allowedModes, ErrorContextCallback::arg, ErrorContextCallback::callback, compile_plperl_function(), dTHX, elog, ereport, errcode(), errmsg(), ERROR, error_context_stack, ExprEndResult, FALSE, plperl_proc_desc::fn_retisset, get_perl_array_ref(), i, 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(), SPI_finish(), SPI_OK_CONNECT, SPI_OK_FINISH, SvREFCNT_dec_current(), and plperl_call_data::tuple_store.

Referenced by plperl_call_handler().

2398 {
2399  plperl_proc_desc *prodesc;
2400  SV *perlret;
2401  Datum retval = 0;
2402  ReturnSetInfo *rsi;
2403  ErrorContextCallback pl_error_context;
2404 
2405  if (SPI_connect() != SPI_OK_CONNECT)
2406  elog(ERROR, "could not connect to SPI manager");
2407 
2408  prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false);
2409  current_call_data->prodesc = prodesc;
2410  increment_prodesc_refcount(prodesc);
2411 
2412  /* Set a callback for error reporting */
2413  pl_error_context.callback = plperl_exec_callback;
2414  pl_error_context.previous = error_context_stack;
2415  pl_error_context.arg = prodesc->proname;
2416  error_context_stack = &pl_error_context;
2417 
2418  rsi = (ReturnSetInfo *) fcinfo->resultinfo;
2419 
2420  if (prodesc->fn_retisset)
2421  {
2422  /* Check context before allowing the call to go through */
2423  if (!rsi || !IsA(rsi, ReturnSetInfo) ||
2424  (rsi->allowedModes & SFRM_Materialize) == 0)
2425  ereport(ERROR,
2426  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
2427  errmsg("set-valued function called in context that "
2428  "cannot accept a set")));
2429  }
2430 
2431  activate_interpreter(prodesc->interp);
2432 
2433  perlret = plperl_call_perl_func(prodesc, fcinfo);
2434 
2435  /************************************************************
2436  * Disconnect from SPI manager and then create the return
2437  * values datum (if the input function does a palloc for it
2438  * this must not be allocated in the SPI memory context
2439  * because SPI_finish would free it).
2440  ************************************************************/
2441  if (SPI_finish() != SPI_OK_FINISH)
2442  elog(ERROR, "SPI_finish() failed");
2443 
2444  if (prodesc->fn_retisset)
2445  {
2446  SV *sav;
2447 
2448  /*
2449  * If the Perl function returned an arrayref, we pretend that it
2450  * called return_next() for each element of the array, to handle old
2451  * SRFs that didn't know about return_next(). Any other sort of return
2452  * value is an error, except undef which means return an empty set.
2453  */
2454  sav = get_perl_array_ref(perlret);
2455  if (sav)
2456  {
2457  dTHX;
2458  int i = 0;
2459  SV **svp = 0;
2460  AV *rav = (AV *) SvRV(sav);
2461 
2462  while ((svp = av_fetch(rav, i, FALSE)) != NULL)
2463  {
2465  i++;
2466  }
2467  }
2468  else if (SvOK(perlret))
2469  {
2470  ereport(ERROR,
2471  (errcode(ERRCODE_DATATYPE_MISMATCH),
2472  errmsg("set-returning PL/Perl function must return "
2473  "reference to array or use return_next")));
2474  }
2475 
2478  {
2481  }
2482  retval = (Datum) 0;
2483  }
2484  else
2485  {
2486  retval = plperl_sv_to_datum(perlret,
2487  prodesc->result_oid,
2488  -1,
2489  fcinfo,
2490  &prodesc->result_in_func,
2491  prodesc->result_typioparam,
2492  &fcinfo->isnull);
2493 
2494  if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo))
2495  rsi->isDone = ExprEndResult;
2496  }
2497 
2498  /* Restore the previous error callback */
2499  error_context_stack = pl_error_context.previous;
2500 
2501  SvREFCNT_dec_current(perlret);
2502 
2503  return retval;
2504 }
#define SPI_OK_CONNECT
Definition: spi.h:50
#define IsA(nodeptr, _type_)
Definition: nodes.h:561
static SV * get_perl_array_ref(SV *sv)
Definition: plperl.c:1146
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
#define dTHX
Definition: ppport.h:3208
int SPI_connect(void)
Definition: spi.c:84
#define FALSE
Definition: ecpglib.h:39
int SPI_finish(void)
Definition: spi.c:149
int errcode(int sqlerrcode)
Definition: elog.c:575
void(* callback)(void *arg)
Definition: elog.h:239
struct ErrorContextCallback * previous
Definition: elog.h:238
ErrorContextCallback * error_context_stack
Definition: elog.c:88
bool fn_retisset
Definition: plperl.c:121
#define ERROR
Definition: elog.h:43
FmgrInfo result_in_func
Definition: plperl.c:125
static plperl_proc_desc * compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger)
Definition: plperl.c:2705
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
static void plperl_exec_callback(void *arg)
Definition: plperl.c:4043
#define increment_prodesc_refcount(prodesc)
Definition: plperl.c:134
Oid result_typioparam
Definition: plperl.c:126
#define ereport(elevel, rest)
Definition: elog.h:122
static void plperl_return_next_internal(SV *sv)
Definition: plperl.c:3241
uintptr_t Datum
Definition: postgres.h:372
Tuplestorestate * tuple_store
Definition: plperl.c:183
static void SvREFCNT_dec_current(SV *sv)
Definition: plperl.c:317
int allowedModes
Definition: execnodes.h:268
TupleDesc ret_tdesc
Definition: plperl.c:184
SetFunctionReturnMode returnMode
Definition: execnodes.h:270
#define SPI_OK_FINISH
Definition: spi.h:51
Tuplestorestate * setResult
Definition: execnodes.h:273
TupleDesc setDesc
Definition: execnodes.h:274
int errmsg(const char *fmt,...)
Definition: elog.c:797
int i
char * proname
Definition: plperl.c:109
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
ExprDoneCond isDone
Definition: execnodes.h:271
plperl_interp_desc * interp
Definition: plperl.c:115
static plperl_call_data * current_call_data
Definition: plperl.c:248
static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
Definition: plperl.c:2173

◆ plperl_hash_from_datum()

static SV * plperl_hash_from_datum ( Datum  attr)
static

Definition at line 2988 of file plperl.c.

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().

2989 {
2990  HeapTupleHeader td;
2991  Oid tupType;
2992  int32 tupTypmod;
2993  TupleDesc tupdesc;
2994  HeapTupleData tmptup;
2995  SV *sv;
2996 
2997  td = DatumGetHeapTupleHeader(attr);
2998 
2999  /* Extract rowtype info and find a tupdesc */
3000  tupType = HeapTupleHeaderGetTypeId(td);
3001  tupTypmod = HeapTupleHeaderGetTypMod(td);
3002  tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod);
3003 
3004  /* Build a temporary HeapTuple control structure */
3005  tmptup.t_len = HeapTupleHeaderGetDatumLength(td);
3006  tmptup.t_data = td;
3007 
3008  sv = plperl_hash_from_tuple(&tmptup, tupdesc);
3009  ReleaseTupleDesc(tupdesc);
3010 
3011  return sv;
3012 }
TupleDesc lookup_rowtype_tupdesc(Oid type_id, int32 typmod)
Definition: typcache.c:1618
unsigned int Oid
Definition: postgres_ext.h:31
#define DatumGetHeapTupleHeader(X)
Definition: fmgr.h:259
signed int int32
Definition: c.h:284
HeapTupleHeader t_data
Definition: htup.h:67
#define HeapTupleHeaderGetTypMod(tup)
Definition: htup_details.h:460
uint32 t_len
Definition: htup.h:64
static SV * plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
Definition: plperl.c:3016
#define HeapTupleHeaderGetTypeId(tup)
Definition: htup_details.h:450
#define ReleaseTupleDesc(tupdesc)
Definition: tupdesc.h:121
#define HeapTupleHeaderGetDatumLength(tup)
Definition: htup_details.h:444

◆ plperl_hash_from_tuple()

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

Definition at line 3016 of file plperl.c.

References check_stack_depth(), cstr2sv(), DatumGetPointer, dTHX, get_base_element_type(), get_transform_fromsql(), getTypeOutputInfo(), heap_getattr, hv_store_string(), i, plperl_proc_desc::lang_oid, NameStr, tupleDesc::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().

3017 {
3018  dTHX;
3019  HV *hv;
3020  int i;
3021 
3022  /* since this function recurses, it could be driven to stack overflow */
3024 
3025  hv = newHV();
3026  hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
3027 
3028  for (i = 0; i < tupdesc->natts; i++)
3029  {
3030  Datum attr;
3031  bool isnull,
3032  typisvarlena;
3033  char *attname;
3034  Oid typoutput;
3035  Form_pg_attribute att = TupleDescAttr(tupdesc, i);
3036 
3037  if (att->attisdropped)
3038  continue;
3039 
3040  attname = NameStr(att->attname);
3041  attr = heap_getattr(tuple, i + 1, tupdesc, &isnull);
3042 
3043  if (isnull)
3044  {
3045  /*
3046  * Store (attname => undef) and move on. Note we can't use
3047  * &PL_sv_undef here; see "AVs, HVs and undefined values" in
3048  * perlguts for an explanation.
3049  */
3050  hv_store_string(hv, attname, newSV(0));
3051  continue;
3052  }
3053 
3054  if (type_is_rowtype(att->atttypid))
3055  {
3056  SV *sv = plperl_hash_from_datum(attr);
3057 
3058  hv_store_string(hv, attname, sv);
3059  }
3060  else
3061  {
3062  SV *sv;
3063  Oid funcid;
3064 
3065  if (OidIsValid(get_base_element_type(att->atttypid)))
3066  sv = plperl_ref_from_pg_array(attr, att->atttypid);
3068  sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr));
3069  else
3070  {
3071  char *outputstr;
3072 
3073  /* XXX should have a way to cache these lookups */
3074  getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena);
3075 
3076  outputstr = OidOutputFunctionCall(typoutput, attr);
3077  sv = cstr2sv(outputstr);
3078  pfree(outputstr);
3079  }
3080 
3081  hv_store_string(hv, attname, sv);
3082  }
3083  }
3084  return newRV_noinc((SV *) hv);
3085 }
static SV * plperl_ref_from_pg_array(Datum arg, Oid typid)
Definition: plperl.c:1468
Oid get_transform_fromsql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1872
List * trftypes
Definition: plperl.c:118
void getTypeOutputInfo(Oid type, Oid *typOutput, bool *typIsVarlena)
Definition: lsyscache.c:2646
#define dTHX
Definition: ppport.h:3208
#define TupleDescAttr(tupdesc, i)
Definition: tupdesc.h:90
static SV * plperl_hash_from_datum(Datum attr)
Definition: plperl.c:2988
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3993
unsigned int Oid
Definition: postgres_ext.h:31
#define OidIsValid(objectId)
Definition: c.h:576
int natts
Definition: tupdesc.h:79
void pfree(void *pointer)
Definition: mcxt.c:949
#define OidFunctionCall1(functionId, arg1)
Definition: fmgr.h:623
void check_stack_depth(void)
Definition: postgres.c:3150
FormData_pg_attribute * Form_pg_attribute
Definition: pg_attribute.h:187
bool type_is_rowtype(Oid typid)
Definition: lsyscache.c:2405
#define heap_getattr(tup, attnum, tupleDesc, isnull)
Definition: htup_details.h:774
#define newRV_noinc(a)
Definition: ppport.h:4456
uintptr_t Datum
Definition: postgres.h:372
static SV * cstr2sv(const char *str)
#define DatumGetPointer(X)
Definition: postgres.h:555
Oid get_base_element_type(Oid typid)
Definition: lsyscache.c:2571
char * OidOutputFunctionCall(Oid functionId, Datum val)
Definition: fmgr.c:1742
int i
#define NameStr(name)
Definition: c.h:547
plperl_proc_desc * prodesc
Definition: plperl.c:180
static plperl_call_data * current_call_data
Definition: plperl.c:248

◆ plperl_hash_to_datum()

static Datum plperl_hash_to_datum ( SV *  src,
TupleDesc  td 
)
static

Definition at line 1134 of file plperl.c.

References HeapTupleGetDatum, and plperl_build_tuple_result().

Referenced by plperl_sv_to_datum().

1135 {
1136  HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), td);
1137 
1138  return HeapTupleGetDatum(tup);
1139 }
#define HeapTupleGetDatum(tuple)
Definition: funcapi.h:230
static HeapTuple plperl_build_tuple_result(HV *perlhash, TupleDesc td)
Definition: plperl.c:1083

◆ plperl_init_interp()

static PerlInterpreter * plperl_init_interp ( void  )
static

Definition at line 713 of file plperl.c.

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().

714 {
715  PerlInterpreter *plperl;
716 
717  static char *embedding[3 + 2] = {
718  "", "-e", PLC_PERLBOOT
719  };
720  int nargs = 3;
721 
722 #ifdef WIN32
723 
724  /*
725  * The perl library on startup does horrible things like call
726  * setlocale(LC_ALL,""). We have protected against that on most platforms
727  * by setting the environment appropriately. However, on Windows,
728  * setlocale() does not consult the environment, so we need to save the
729  * existing locale settings before perl has a chance to mangle them and
730  * restore them after its dirty deeds are done.
731  *
732  * MSDN ref:
733  * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp
734  *
735  * It appears that we only need to do this on interpreter startup, and
736  * subsequent calls to the interpreter don't mess with the locale
737  * settings.
738  *
739  * We restore them using setlocale_perl(), defined below, so that Perl
740  * doesn't have a different idea of the locale from Postgres.
741  *
742  */
743 
744  char *loc;
745  char *save_collate,
746  *save_ctype,
747  *save_monetary,
748  *save_numeric,
749  *save_time;
750 
751  loc = setlocale(LC_COLLATE, NULL);
752  save_collate = loc ? pstrdup(loc) : NULL;
753  loc = setlocale(LC_CTYPE, NULL);
754  save_ctype = loc ? pstrdup(loc) : NULL;
755  loc = setlocale(LC_MONETARY, NULL);
756  save_monetary = loc ? pstrdup(loc) : NULL;
757  loc = setlocale(LC_NUMERIC, NULL);
758  save_numeric = loc ? pstrdup(loc) : NULL;
759  loc = setlocale(LC_TIME, NULL);
760  save_time = loc ? pstrdup(loc) : NULL;
761 
762 #define PLPERL_RESTORE_LOCALE(name, saved) \
763  STMT_START { \
764  if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \
765  } STMT_END
766 #endif /* WIN32 */
767 
769  {
770  embedding[nargs++] = "-e";
771  embedding[nargs++] = plperl_on_init;
772  }
773 
774  /*
775  * The perl API docs state that PERL_SYS_INIT3 should be called before
776  * allocating interpreters. Unfortunately, on some platforms this fails in
777  * the Perl_do_taint() routine, which is called when the platform is using
778  * the system's malloc() instead of perl's own. Other platforms, notably
779  * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's
780  * available, unless perl is using the system malloc(), which is true when
781  * MYMALLOC is set.
782  */
783 #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
784  {
785  static int perl_sys_init_done;
786 
787  /* only call this the first time through, as per perlembed man page */
788  if (!perl_sys_init_done)
789  {
790  char *dummy_env[1] = {NULL};
791 
792  PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
793 
794  /*
795  * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to
796  * SIG_IGN. Aside from being extremely unfriendly behavior for a
797  * library, this is dumb on the grounds that the results of a
798  * SIGFPE in this state are undefined according to POSIX, and in
799  * fact you get a forced process kill at least on Linux. Hence,
800  * restore the SIGFPE handler to the backend's standard setting.
801  * (See Perl bug 114574 for more information.)
802  */
804 
805  perl_sys_init_done = 1;
806  /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */
807  dummy_env[0] = NULL;
808  }
809  }
810 #endif
811 
812  plperl = perl_alloc();
813  if (!plperl)
814  elog(ERROR, "could not allocate Perl interpreter");
815 
816  PERL_SET_CONTEXT(plperl);
817  perl_construct(plperl);
818 
819  /*
820  * Run END blocks in perl_destruct instead of perl_run. Note that dTHX
821  * loads up a pointer to the current interpreter, so we have to postpone
822  * it to here rather than put it at the function head.
823  */
824  {
825  dTHX;
826 
827  PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
828 
829  /*
830  * Record the original function for the 'require' and 'dofile'
831  * opcodes. (They share the same implementation.) Ensure it's used
832  * for new interpreters.
833  */
834  if (!pp_require_orig)
835  pp_require_orig = PL_ppaddr[OP_REQUIRE];
836  else
837  {
838  PL_ppaddr[OP_REQUIRE] = pp_require_orig;
839  PL_ppaddr[OP_DOFILE] = pp_require_orig;
840  }
841 
842 #ifdef PLPERL_ENABLE_OPMASK_EARLY
843 
844  /*
845  * For regression testing to prove that the PLC_PERLBOOT and
846  * PLC_TRUSTED code doesn't even compile any unsafe ops. In future
847  * there may be a valid need for them to do so, in which case this
848  * could be softened (perhaps moved to plperl_trusted_init()) or
849  * removed.
850  */
851  PL_op_mask = plperl_opmask;
852 #endif
853 
854  if (perl_parse(plperl, plperl_init_shared_libs,
855  nargs, embedding, NULL) != 0)
856  ereport(ERROR,
857  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
859  errcontext("while parsing Perl initialization")));
860 
861  if (perl_run(plperl) != 0)
862  ereport(ERROR,
863  (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION),
865  errcontext("while running Perl initialization")));
866 
867 #ifdef PLPERL_RESTORE_LOCALE
868  PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate);
869  PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype);
870  PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary);
871  PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric);
872  PLPERL_RESTORE_LOCALE(LC_TIME, save_time);
873 #endif
874  }
875 
876  return plperl;
877 }
static char plperl_opmask[MAXO]
Definition: plperl.c:245
#define PL_ppaddr
Definition: ppport.h:4085
static char * plperl_on_init
Definition: plperl.c:239
static void plperl_init_shared_libs(pTHX)
Definition: plperl.c:2161
#define setlocale(a, b)
Definition: win32_port.h:419
#define dTHX
Definition: ppport.h:3208
char * pstrdup(const char *in)
Definition: mcxt.c:1076
int errcode(int sqlerrcode)
Definition: elog.c:575
#define ERRSV
Definition: ppport.h:3859
static OP *(* pp_require_orig)(pTHX)
Definition: plperl.c:244
#define ERROR
Definition: elog.h:43
#define ereport(elevel, rest)
Definition: elog.h:122
pqsigfunc pqsignal(int signum, pqsigfunc handler)
Definition: signal.c:168
static char * strip_trailing_ws(const char *msg)
Definition: plperl.c:1069
int errmsg(const char *fmt,...)
Definition: elog.c:797
void FloatExceptionHandler(SIGNAL_ARGS)
Definition: postgres.c:2704
#define errcontext
Definition: elog.h:164
#define elog
Definition: elog.h:219
static char * sv2cstr(SV *sv)

◆ plperl_init_shared_libs()

static void plperl_init_shared_libs ( pTHX  )
static

Definition at line 2161 of file plperl.c.

References boot_DynaLoader(), and boot_PostgreSQL__InServer__Util().

Referenced by plperl_init_interp().

2162 {
2163  char *file = __FILE__;
2164 
2165  newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
2166  newXS("PostgreSQL::InServer::Util::bootstrap",
2168  /* newXS for...::SPI::bootstrap is in select_perl_context() */
2169 }
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv)
EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv)

◆ plperl_inline_callback()

static void plperl_inline_callback ( void *  arg)
static

Definition at line 4067 of file plperl.c.

References dTHX, errcontext, locale, and setlocale.

Referenced by plperl_inline_handler().

4068 {
4069  errcontext("PL/Perl anonymous code block");
4070 }
#define errcontext
Definition: elog.h:164

◆ plperl_inline_handler()

Datum plperl_inline_handler ( PG_FUNCTION_ARGS  )

Definition at line 1876 of file plperl.c.

References activate_interpreter(), ErrorContextCallback::arg, ErrorContextCallback::callback, current_call_data, CurrentMemoryContext, elog, ERROR, error_context_stack, plperl_call_data::fcinfo, FunctionCallInfoData::flinfo, FmgrInfo::fn_mcxt, FmgrInfo::fn_oid, plperl_proc_desc::fn_readonly, plperl_proc_desc::fn_retisarray, plperl_proc_desc::fn_retisset, plperl_proc_desc::fn_retistuple, InvalidOid, plperl_proc_desc::lang_oid, InlineCodeBlock::langIsTrusted, InlineCodeBlock::langOid, plperl_proc_desc::lanpltrusted, MemSet, plperl_proc_desc::nargs, NIL, PG_CATCH, PG_END_TRY, PG_FUNCTION_INFO_V1(), PG_GETARG_POINTER, PG_RE_THROW, PG_RETURN_VOID, PG_TRY, plperl_active_interp, plperl_call_perl_func(), plperl_create_sub(), plperl_inline_callback(), plperl_validator(), ErrorContextCallback::previous, plperl_call_data::prodesc, plperl_proc_desc::proname, plperl_proc_desc::reference, plperl_proc_desc::result_oid, select_perl_context(), InlineCodeBlock::source_text, SPI_connect(), SPI_finish(), SPI_OK_CONNECT, SPI_OK_FINISH, SvREFCNT_dec_current(), plperl_proc_desc::trftypes, and VOIDOID.

Referenced by plperl_call_handler(), and plperlu_inline_handler().

1877 {
1879  FunctionCallInfoData fake_fcinfo;
1880  FmgrInfo flinfo;
1881  plperl_proc_desc desc;
1882  plperl_call_data *volatile save_call_data = current_call_data;
1883  plperl_interp_desc *volatile oldinterp = plperl_active_interp;
1884  plperl_call_data this_call_data;
1885  ErrorContextCallback pl_error_context;
1886 
1887  /* Initialize current-call status record */
1888  MemSet(&this_call_data, 0, sizeof(this_call_data));
1889 
1890  /* Set up a callback for error reporting */
1891  pl_error_context.callback = plperl_inline_callback;
1892  pl_error_context.previous = error_context_stack;
1893  pl_error_context.arg = NULL;
1894  error_context_stack = &pl_error_context;
1895 
1896  /*
1897  * Set up a fake fcinfo and descriptor with just enough info to satisfy
1898  * plperl_call_perl_func(). In particular note that this sets things up
1899  * with no arguments passed, and a result type of VOID.
1900  */
1901  MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo));
1902  MemSet(&flinfo, 0, sizeof(flinfo));
1903  MemSet(&desc, 0, sizeof(desc));
1904  fake_fcinfo.flinfo = &flinfo;
1905  flinfo.fn_oid = InvalidOid;
1906  flinfo.fn_mcxt = CurrentMemoryContext;
1907 
1908  desc.proname = "inline_code_block";
1909  desc.fn_readonly = false;
1910 
1911  desc.lang_oid = codeblock->langOid;
1912  desc.trftypes = NIL;
1913  desc.lanpltrusted = codeblock->langIsTrusted;
1914 
1915  desc.fn_retistuple = false;
1916  desc.fn_retisset = false;
1917  desc.fn_retisarray = false;
1918  desc.result_oid = VOIDOID;
1919  desc.nargs = 0;
1920  desc.reference = NULL;
1921 
1922  this_call_data.fcinfo = &fake_fcinfo;
1923  this_call_data.prodesc = &desc;
1924  /* we do not bother with refcounting the fake prodesc */
1925 
1926  PG_TRY();
1927  {
1928  SV *perlret;
1929 
1930  current_call_data = &this_call_data;
1931 
1932  if (SPI_connect() != SPI_OK_CONNECT)
1933  elog(ERROR, "could not connect to SPI manager");
1934 
1936 
1937  plperl_create_sub(&desc, codeblock->source_text, 0);
1938 
1939  if (!desc.reference) /* can this happen? */
1940  elog(ERROR, "could not create internal procedure for anonymous code block");
1941 
1942  perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
1943 
1944  SvREFCNT_dec_current(perlret);
1945 
1946  if (SPI_finish() != SPI_OK_FINISH)
1947  elog(ERROR, "SPI_finish() failed");
1948  }
1949  PG_CATCH();
1950  {
1951  if (desc.reference)
1953  current_call_data = save_call_data;
1954  activate_interpreter(oldinterp);
1955  PG_RE_THROW();
1956  }
1957  PG_END_TRY();
1958 
1959  if (desc.reference)
1961 
1962  current_call_data = save_call_data;
1963  activate_interpreter(oldinterp);
1964 
1965  error_context_stack = pl_error_context.previous;
1966 
1967  PG_RETURN_VOID();
1968 }
#define NIL
Definition: pg_list.h:69
#define SPI_OK_CONNECT
Definition: spi.h:50
Definition: fmgr.h:56
List * trftypes
Definition: plperl.c:118
MemoryContext fn_mcxt
Definition: fmgr.h:65
FunctionCallInfo fcinfo
Definition: plperl.c:181
static void select_perl_context(bool trusted)
Definition: plperl.c:560
int SPI_connect(void)
Definition: spi.c:84
int SPI_finish(void)
Definition: spi.c:149
#define MemSet(start, val, len)
Definition: c.h:853
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
#define PG_GETARG_POINTER(n)
Definition: fmgr.h:241
void(* callback)(void *arg)
Definition: elog.h:239
struct ErrorContextCallback * previous
Definition: elog.h:238
ErrorContextCallback * error_context_stack
Definition: elog.c:88
FmgrInfo * flinfo
Definition: fmgr.h:79
bool fn_retisset
Definition: plperl.c:121
#define VOIDOID
Definition: pg_type.h:690
#define ERROR
Definition: elog.h:43
static void activate_interpreter(plperl_interp_desc *interp_desc)
Definition: plperl.c:692
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
static void SvREFCNT_dec_current(SV *sv)
Definition: plperl.c:317
#define InvalidOid
Definition: postgres_ext.h:36
Oid fn_oid
Definition: fmgr.h:59
bool fn_readonly
Definition: plperl.c:116
static void plperl_inline_callback(void *arg)
Definition: plperl.c:4067
#define PG_RETURN_VOID()
Definition: fmgr.h:309
#define PG_CATCH()
Definition: elog.h:293
SV * reference
Definition: plperl.c:114
#define SPI_OK_FINISH
Definition: spi.h:51
#define PG_RE_THROW()
Definition: elog.h:314
bool fn_retistuple
Definition: plperl.c:120
static void plperl_create_sub(plperl_proc_desc *desc, const char *s, Oid fn_oid)
Definition: plperl.c:2086
char * proname
Definition: plperl.c:109
char * source_text
Definition: parsenodes.h:2797
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
#define PG_TRY()
Definition: elog.h:284
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define PG_END_TRY()
Definition: elog.h:300
bool lanpltrusted
Definition: plperl.c:119
static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
Definition: plperl.c:2173
bool fn_retisarray
Definition: plperl.c:122

◆ plperl_modify_tuple()

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

Definition at line 1744 of file plperl.c.

References dTHX, ereport, errcode(), errmsg(), ERROR, heap_modify_tuple(), hek2cstr(), hv_fetch_string(), InvalidOid, tupleDesc::natts, palloc0(), pfree(), PG_FUNCTION_INFO_V1(), plperl_call_handler(), plperl_sv_to_datum(), RelationData::rd_att, SPI_ERROR_NOATTRIBUTE, SPI_fnumber(), TriggerData::tg_relation, TupleDescAttr, and val.

Referenced by plperl_trigger_handler().

1745 {
1746  dTHX;
1747  SV **svp;
1748  HV *hvNew;
1749  HE *he;
1750  HeapTuple rtup;
1751  TupleDesc tupdesc;
1752  int natts;
1753  Datum *modvalues;
1754  bool *modnulls;
1755  bool *modrepls;
1756 
1757  svp = hv_fetch_string(hvTD, "new");
1758  if (!svp)
1759  ereport(ERROR,
1760  (errcode(ERRCODE_UNDEFINED_COLUMN),
1761  errmsg("$_TD->{new} does not exist")));
1762  if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
1763  ereport(ERROR,
1764  (errcode(ERRCODE_DATATYPE_MISMATCH),
1765  errmsg("$_TD->{new} is not a hash reference")));
1766  hvNew = (HV *) SvRV(*svp);
1767 
1768  tupdesc = tdata->tg_relation->rd_att;
1769  natts = tupdesc->natts;
1770 
1771  modvalues = (Datum *) palloc0(natts * sizeof(Datum));
1772  modnulls = (bool *) palloc0(natts * sizeof(bool));
1773  modrepls = (bool *) palloc0(natts * sizeof(bool));
1774 
1775  hv_iterinit(hvNew);
1776  while ((he = hv_iternext(hvNew)))
1777  {
1778  char *key = hek2cstr(he);
1779  SV *val = HeVAL(he);
1780  int attn = SPI_fnumber(tupdesc, key);
1781  Form_pg_attribute attr = TupleDescAttr(tupdesc, attn - 1);
1782 
1783  if (attn == SPI_ERROR_NOATTRIBUTE)
1784  ereport(ERROR,
1785  (errcode(ERRCODE_UNDEFINED_COLUMN),
1786  errmsg("Perl hash contains nonexistent column \"%s\"",
1787  key)));
1788  if (attn <= 0)
1789  ereport(ERROR,
1790  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1791  errmsg("cannot set system attribute \"%s\"",
1792  key)));
1793 
1794  modvalues[attn - 1] = plperl_sv_to_datum(val,
1795  attr->atttypid,
1796  attr->atttypmod,
1797  NULL,
1798  NULL,
1799  InvalidOid,
1800  &modnulls[attn - 1]);
1801  modrepls[attn - 1] = true;
1802 
1803  pfree(key);
1804  }
1805  hv_iterinit(hvNew);
1806 
1807  rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls);
1808 
1809  pfree(modvalues);
1810  pfree(modnulls);
1811  pfree(modrepls);
1812 
1813  return rtup;
1814 }
int SPI_fnumber(TupleDesc tupdesc, const char *fname)
Definition: spi.c:767
static char * hek2cstr(HE *he)
Definition: plperl.c:328
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
#define dTHX
Definition: ppport.h:3208
#define TupleDescAttr(tupdesc, i)
Definition: tupdesc.h:90
int errcode(int sqlerrcode)
Definition: elog.c:575
static SV ** hv_fetch_string(HV *hv, const char *key)
Definition: plperl.c:4020
int natts
Definition: tupdesc.h:79
void pfree(void *pointer)
Definition: mcxt.c:949
#define ERROR
Definition: elog.h:43
#define SPI_ERROR_NOATTRIBUTE
Definition: spi.h:44
FormData_pg_attribute * Form_pg_attribute
Definition: pg_attribute.h:187
#define ereport(elevel, rest)
Definition: elog.h:122
void * palloc0(Size size)
Definition: mcxt.c:877
uintptr_t Datum
Definition: postgres.h:372
TupleDesc rd_att
Definition: rel.h:115
#define InvalidOid
Definition: postgres_ext.h:36
int errmsg(const char *fmt,...)
Definition: elog.c:797
HeapTuple heap_modify_tuple(HeapTuple tuple, TupleDesc tupleDesc, Datum *replValues, bool *replIsnull, bool *doReplace)
Definition: heaptuple.c:794
long val
Definition: informix.c:689
Relation tg_relation
Definition: trigger.h:34

◆ plperl_ref_from_pg_array()

static SV * plperl_ref_from_pg_array ( Datum  arg,
Oid  typid 
)
static

Definition at line 1468 of file plperl.c.

References ARR_DIMS, ARR_ELEMTYPE, ARR_NDIM, av, 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, 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, and type_is_rowtype().

Referenced by plperl_call_perl_func(), and plperl_hash_from_tuple().

1469 {
1470  dTHX;
1472  Oid elementtype = ARR_ELEMTYPE(ar);
1473  int16 typlen;
1474  bool typbyval;
1475  char typalign,
1476  typdelim;
1477  Oid typioparam;
1478  Oid typoutputfunc;
1479  Oid transform_funcid;
1480  int i,
1481  nitems,
1482  *dims;
1483  plperl_array_info *info;
1484  SV *av;
1485  HV *hv;
1486 
1487  /*
1488  * Currently we make no effort to cache any of the stuff we look up here,
1489  * which is bad.
1490  */
1491  info = palloc0(sizeof(plperl_array_info));
1492 
1493  /* get element type information, including output conversion function */
1494  get_type_io_data(elementtype, IOFunc_output,
1495  &typlen, &typbyval, &typalign,
1496  &typdelim, &typioparam, &typoutputfunc);
1497 
1498  /* Check for a transform function */
1499  transform_funcid = get_transform_fromsql(elementtype,
1502 
1503  /* Look up transform or output function as appropriate */
1504  if (OidIsValid(transform_funcid))
1505  fmgr_info(transform_funcid, &info->transform_proc);
1506  else
1507  fmgr_info(typoutputfunc, &info->proc);
1508 
1509  info->elem_is_rowtype = type_is_rowtype(elementtype);
1510 
1511  /* Get the number and bounds of array dimensions */
1512  info->ndims = ARR_NDIM(ar);
1513  dims = ARR_DIMS(ar);
1514 
1515  /* No dimensions? Return an empty array */
1516  if (info->ndims == 0)
1517  {
1518  av = newRV_noinc((SV *) newAV());
1519  }
1520  else
1521  {
1522  deconstruct_array(ar, elementtype, typlen, typbyval,
1523  typalign, &info->elements, &info->nulls,
1524  &nitems);
1525 
1526  /* Get total number of elements in each dimension */
1527  info->nelems = palloc(sizeof(int) * info->ndims);
1528  info->nelems[0] = nitems;
1529  for (i = 1; i < info->ndims; i++)
1530  info->nelems[i] = info->nelems[i - 1] / dims[i - 1];
1531 
1532  av = split_array(info, 0, nitems, 0);
1533  }
1534 
1535  hv = newHV();
1536  (void) hv_store(hv, "array", 5, av, 0);
1537  (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0);
1538 
1539  return sv_bless(newRV_noinc((SV *) hv),
1540  gv_stashpv("PostgreSQL::InServer::ARRAY", 0));
1541 }
signed short int16
Definition: c.h:283
FmgrInfo transform_proc
Definition: plperl.c:223
Oid get_transform_fromsql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1872
List * trftypes
Definition: plperl.c:118
#define dTHX
Definition: ppport.h:3208
unsigned int Oid
Definition: postgres_ext.h:31
#define OidIsValid(objectId)
Definition: c.h:576
static SV * split_array(plperl_array_info *info, int first, int last, int nest)
Definition: plperl.c:1547
#define newSVuv(uv)
Definition: ppport.h:3596
#define ARR_DIMS(a)
Definition: array.h:279
void fmgr_info(Oid functionId, FmgrInfo *finfo)
Definition: fmgr.c:122
bool type_is_rowtype(Oid typid)
Definition: lsyscache.c:2405
#define newRV_noinc(a)
Definition: ppport.h:4456
struct @18::@19 av[32]
void * palloc0(Size size)
Definition: mcxt.c:877
bool elem_is_rowtype
Definition: plperl.c:218
#define ARR_NDIM(a)
Definition: array.h:275
FmgrInfo proc
Definition: plperl.c:222
void deconstruct_array(ArrayType *array, Oid elmtype, int elmlen, bool elmbyval, char elmalign, Datum **elemsp, bool **nullsp, int *nelemsp)
Definition: arrayfuncs.c:3449
bool * nulls
Definition: plperl.c:220
void * palloc(Size size)
Definition: mcxt.c:848
int i
Datum * elements
Definition: plperl.c:219
void * arg
plperl_proc_desc * prodesc
Definition: plperl.c:180
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define ARR_ELEMTYPE(a)
Definition: array.h:277
#define DatumGetArrayTypeP(X)
Definition: array.h:246
void get_type_io_data(Oid typid, IOFuncSelector which_func, int16 *typlen, bool *typbyval, char *typalign, char *typdelim, Oid *typioparam, Oid *func)
Definition: lsyscache.c:2075

◆ plperl_return_next()

void plperl_return_next ( SV *  sv)

Definition at line 3213 of file plperl.c.

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

3214 {
3215  MemoryContext oldcontext = CurrentMemoryContext;
3216 
3217  PG_TRY();
3218  {
3220  }
3221  PG_CATCH();
3222  {
3223  ErrorData *edata;
3224 
3225  /* Must reset elog.c's state */
3226  MemoryContextSwitchTo(oldcontext);
3227  edata = CopyErrorData();
3228  FlushErrorState();
3229 
3230  /* Punt the error to Perl */
3231  croak_cstr(edata->message);
3232  }
3233  PG_END_TRY();
3234 }
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
void FlushErrorState(void)
Definition: elog.c:1587
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
static void plperl_return_next_internal(SV *sv)
Definition: plperl.c:3241
static void croak_cstr(const char *str)
#define PG_CATCH()
Definition: elog.h:293
#define PG_TRY()
Definition: elog.h:284
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343

◆ plperl_return_next_internal()

static void plperl_return_next_internal ( SV *  sv)
static

Definition at line 3241 of file plperl.c.

References ALLOCSET_DEFAULT_SIZES, AllocSetContextCreate(), ReturnSetInfo::allowedModes, Assert, plperl_call_data::cdomain_info, plperl_call_data::cdomain_oid, CreateTupleDescCopy(), 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, MemoryContextReset(), MemoryContextSwitchTo(), tupleDesc::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, FunctionCallInfoData::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().

3242 {
3243  plperl_proc_desc *prodesc;
3244  FunctionCallInfo fcinfo;
3245  ReturnSetInfo *rsi;
3246  MemoryContext old_cxt;
3247 
3248  if (!sv)
3249  return;
3250 
3251  prodesc = current_call_data->prodesc;
3252  fcinfo = current_call_data->fcinfo;
3253  rsi = (ReturnSetInfo *) fcinfo->resultinfo;
3254 
3255  if (!prodesc->fn_retisset)
3256  ereport(ERROR,
3257  (errcode(ERRCODE_SYNTAX_ERROR),
3258  errmsg("cannot use return_next in a non-SETOF function")));
3259 
3261  {
3262  TupleDesc tupdesc;
3263 
3265 
3266  /*
3267  * This is the first call to return_next in the current PL/Perl
3268  * function call, so identify the output tuple type and create a
3269  * tuplestore to hold the result rows.
3270  */
3271  if (prodesc->fn_retistuple)
3272  {
3273  TypeFuncClass funcclass;
3274  Oid typid;
3275 
3276  funcclass = get_call_result_type(fcinfo, &typid, &tupdesc);
3277  if (funcclass != TYPEFUNC_COMPOSITE &&
3278  funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
3279  ereport(ERROR,
3280  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
3281  errmsg("function returning record called in context "
3282  "that cannot accept type record")));
3283  /* if domain-over-composite, remember the domain's type OID */
3284  if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN)
3285  current_call_data->cdomain_oid = typid;
3286  }
3287  else
3288  {
3289  tupdesc = rsi->expectedDesc;
3290  /* Protect assumption below that we return exactly one column */
3291  if (tupdesc == NULL || tupdesc->natts != 1)
3292  elog(ERROR, "expected single-column result descriptor for non-composite SETOF result");
3293  }
3294 
3295  /*
3296  * Make sure the tuple_store and ret_tdesc are sufficiently
3297  * long-lived.
3298  */
3300 
3304  false, work_mem);
3305 
3306  MemoryContextSwitchTo(old_cxt);
3307  }
3308 
3309  /*
3310  * Producing the tuple we want to return requires making plenty of
3311  * palloc() allocations that are not cleaned up. Since this function can
3312  * be called many times before the current memory context is reset, we
3313  * need to do those allocations in a temporary context.
3314  */
3315  if (!current_call_data->tmp_cxt)
3316  {
3319  "PL/Perl return_next temporary cxt",
3321  }
3322 
3324 
3325  if (prodesc->fn_retistuple)
3326  {
3327  HeapTuple tuple;
3328 
3329  if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
3330  ereport(ERROR,
3331  (errcode(ERRCODE_DATATYPE_MISMATCH),
3332  errmsg("SETOF-composite-returning PL/Perl function "
3333  "must call return_next with reference to hash")));
3334 
3335  tuple = plperl_build_tuple_result((HV *) SvRV(sv),
3337 
3339  domain_check(HeapTupleGetDatum(tuple), false,
3343 
3345  }
3346  else
3347  {
3348  Datum ret[1];
3349  bool isNull[1];
3350 
3351  ret[0] = plperl_sv_to_datum(sv,
3352  prodesc->result_oid,
3353  -1,
3354  fcinfo,
3355  &prodesc->result_in_func,
3356  prodesc->result_typioparam,
3357  &isNull[0]);
3358 
3361  ret, isNull);
3362  }
3363 
3364  MemoryContextSwitchTo(old_cxt);
3366 }
void tuplestore_putvalues(Tuplestorestate *state, TupleDesc tdesc, Datum *values, bool *isnull)
Definition: tuplestore.c:750
TupleDesc CreateTupleDescCopy(TupleDesc tupdesc)
Definition: tupdesc.c:102
TypeFuncClass get_call_result_type(FunctionCallInfo fcinfo, Oid *resultTypeId, TupleDesc *resultTupleDesc)
Definition: funcapi.c:211
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
FunctionCallInfo fcinfo
Definition: plperl.c:181
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
int errcode(int sqlerrcode)
Definition: elog.c:575
void MemoryContextReset(MemoryContext context)
Definition: mcxt.c:135
unsigned int Oid
Definition: postgres_ext.h:31
#define OidIsValid(objectId)
Definition: c.h:576
int natts
Definition: tupdesc.h:79
void * cdomain_info
Definition: plperl.c:186
TupleDesc expectedDesc
Definition: execnodes.h:267
bool fn_retisset
Definition: plperl.c:121
#define ERROR
Definition: elog.h:43
FmgrInfo result_in_func
Definition: plperl.c:125
#define ALLOCSET_DEFAULT_SIZES
Definition: memutils.h:165
void tuplestore_puttuple(Tuplestorestate *state, HeapTuple tuple)
Definition: tuplestore.c:730
fmNodePtr resultinfo
Definition: fmgr.h:81
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
TypeFuncClass
Definition: funcapi.h:155
Oid result_typioparam
Definition: plperl.c:126
#define ereport(elevel, rest)
Definition: elog.h:122
Tuplestorestate * tuplestore_begin_heap(bool randomAccess, bool interXact, int maxKBytes)
Definition: tuplestore.c:318
MemoryContext AllocSetContextCreate(MemoryContext parent, const char *name, Size minContextSize, Size initBlockSize, Size maxBlockSize)
Definition: aset.c:322
uintptr_t Datum
Definition: postgres.h:372
int work_mem
Definition: globals.c:113
Tuplestorestate * tuple_store
Definition: plperl.c:183
void domain_check(Datum value, bool isnull, Oid domainType, void **extra, MemoryContext mcxt)
Definition: domains.c:327
int allowedModes
Definition: execnodes.h:268
TupleDesc ret_tdesc
Definition: plperl.c:184
MemoryContext tmp_cxt
Definition: plperl.c:187
#define Assert(condition)
Definition: c.h:670
#define HeapTupleGetDatum(tuple)
Definition: funcapi.h:230
MemoryContext ecxt_per_query_memory
Definition: execnodes.h:202
static HeapTuple plperl_build_tuple_result(HV *perlhash, TupleDesc td)
Definition: plperl.c:1083
ExprContext * econtext
Definition: execnodes.h:266
int errmsg(const char *fmt,...)
Definition: elog.c:797
bool fn_retistuple
Definition: plperl.c:120
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
static plperl_call_data * current_call_data
Definition: plperl.c:248

◆ plperl_spi_cursor_close()

void plperl_spi_cursor_close ( char *  cursor)

Definition at line 3513 of file plperl.c.

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

3514 {
3515  Portal p;
3516 
3518 
3519  p = SPI_cursor_find(cursor);
3520 
3521  if (p)
3522  SPI_cursor_close(p);
3523 }
Portal SPI_cursor_find(const char *name)
Definition: spi.c:1343
Definition: type.h:124
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
void SPI_cursor_close(Portal portal)
Definition: spi.c:1411

◆ plperl_spi_exec()

HV* plperl_spi_exec ( char *  query,
int  limit 
)

Definition at line 3101 of file plperl.c.

References BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), 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.

3102 {
3103  HV *ret_hv;
3104 
3105  /*
3106  * Execute the query inside a sub-transaction, so we can cope with errors
3107  * sanely
3108  */
3109  MemoryContext oldcontext = CurrentMemoryContext;
3111 
3113 
3115  /* Want to run inside function's memory context */
3116  MemoryContextSwitchTo(oldcontext);
3117 
3118  PG_TRY();
3119  {
3120  int spi_rv;
3121 
3122  pg_verifymbstr(query, strlen(query), false);
3123 
3125  limit);
3127  spi_rv);
3128 
3129  /* Commit the inner transaction, return to outer xact context */
3131  MemoryContextSwitchTo(oldcontext);
3132  CurrentResourceOwner = oldowner;
3133  }
3134  PG_CATCH();
3135  {
3136  ErrorData *edata;
3137 
3138  /* Save error info */
3139  MemoryContextSwitchTo(oldcontext);
3140  edata = CopyErrorData();
3141  FlushErrorState();
3142 
3143  /* Abort the inner transaction */
3145  MemoryContextSwitchTo(oldcontext);
3146  CurrentResourceOwner = oldowner;
3147 
3148  /* Punt the error to Perl */
3149  croak_cstr(edata->message);
3150 
3151  /* Can't get here, but keep compiler quiet */
3152  return NULL;
3153  }
3154  PG_END_TRY();
3155 
3156  return ret_hv;
3157 }
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
SPITupleTable * SPI_tuptable
Definition: spi.c:41
void FlushErrorState(void)
Definition: elog.c:1587
uint64 SPI_processed
Definition: spi.c:39
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
static void croak_cstr(const char *str)
bool fn_readonly
Definition: plperl.c:116
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
static HV * plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int)
Definition: plperl.c:3161
bool pg_verifymbstr(const char *mbstr, int len, bool noError)
Definition: wchar.c:1866
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define PG_TRY()
Definition: elog.h:284
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343
int SPI_execute(const char *src, bool read_only, long tcount)
Definition: spi.c:310

◆ plperl_spi_exec_prepared()

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

Definition at line 3674 of file plperl.c.

References plperl_query_desc::arginfuncs, plperl_query_desc::argtypes, plperl_query_desc::argtypioparams, BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), 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_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.

3675 {
3676  HV *ret_hv;
3677  SV **sv;
3678  int i,
3679  limit,
3680  spi_rv;
3681  char *nulls;
3682  Datum *argvalues;
3683  plperl_query_desc *qdesc;
3684  plperl_query_entry *hash_entry;
3685 
3686  /*
3687  * Execute the query inside a sub-transaction, so we can cope with errors
3688  * sanely
3689  */
3690  MemoryContext oldcontext = CurrentMemoryContext;
3692 
3694 
3696  /* Want to run inside function's memory context */
3697  MemoryContextSwitchTo(oldcontext);
3698 
3699  PG_TRY();
3700  {
3701  dTHX;
3702 
3703  /************************************************************
3704  * Fetch the saved plan descriptor, see if it's o.k.
3705  ************************************************************/
3706  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3707  HASH_FIND, NULL);
3708  if (hash_entry == NULL)
3709  elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
3710 
3711  qdesc = hash_entry->query_data;
3712  if (qdesc == NULL)
3713  elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished");
3714 
3715  if (qdesc->nargs != argc)
3716  elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed",
3717  qdesc->nargs, argc);
3718 
3719  /************************************************************
3720  * Parse eventual attributes
3721  ************************************************************/
3722  limit = 0;
3723  if (attr != NULL)
3724  {
3725  sv = hv_fetch_string(attr, "limit");
3726  if (sv && *sv && SvIOK(*sv))
3727  limit = SvIV(*sv);
3728  }
3729  /************************************************************
3730  * Set up arguments
3731  ************************************************************/
3732  if (argc > 0)
3733  {
3734  nulls = (char *) palloc(argc);
3735  argvalues = (Datum *) palloc(argc * sizeof(Datum));
3736  }
3737  else
3738  {
3739  nulls = NULL;
3740  argvalues = NULL;
3741  }
3742 
3743  for (i = 0; i < argc; i++)
3744  {
3745  bool isnull;
3746 
3747  argvalues[i] = plperl_sv_to_datum(argv[i],
3748  qdesc->argtypes[i],
3749  -1,
3750  NULL,
3751  &qdesc->arginfuncs[i],
3752  qdesc->argtypioparams[i],
3753  &isnull);
3754  nulls[i] = isnull ? 'n' : ' ';
3755  }
3756 
3757  /************************************************************
3758  * go
3759  ************************************************************/
3760  spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls,
3763  spi_rv);
3764  if (argc > 0)
3765  {
3766  pfree(argvalues);
3767  pfree(nulls);
3768  }
3769 
3770  /* Commit the inner transaction, return to outer xact context */
3772  MemoryContextSwitchTo(oldcontext);
3773  CurrentResourceOwner = oldowner;
3774  }
3775  PG_CATCH();
3776  {
3777  ErrorData *edata;
3778 
3779  /* Save error info */
3780  MemoryContextSwitchTo(oldcontext);
3781  edata = CopyErrorData();
3782  FlushErrorState();
3783 
3784  /* Abort the inner transaction */
3786  MemoryContextSwitchTo(oldcontext);
3787  CurrentResourceOwner = oldowner;
3788 
3789  /* Punt the error to Perl */
3790  croak_cstr(edata->message);
3791 
3792  /* Can't get here, but keep compiler quiet */
3793  return NULL;
3794  }
3795  PG_END_TRY();
3796 
3797  return ret_hv;
3798 }
Definition: plperl.c:206
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
HTAB * query_hash
Definition: plperl.c:94
#define dTHX
Definition: ppport.h:3208
SPIPlanPtr plan
Definition: plperl.c:197
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
Oid * argtypioparams
Definition: plperl.c:201
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
SPITupleTable * SPI_tuptable
Definition: spi.c:41
static SV ** hv_fetch_string(HV *hv, const char *key)
Definition: plperl.c:4020
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
void FlushErrorState(void)
Definition: elog.c:1587
uint64 SPI_processed
Definition: spi.c:39
void pfree(void *pointer)
Definition: mcxt.c:949
#define ERROR
Definition: elog.h:43
int SPI_execute_plan(SPIPlanPtr plan, Datum *Values, const char *Nulls, bool read_only, long tcount)
Definition: spi.c:345
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
Oid * argtypes
Definition: plperl.c:199
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
uintptr_t Datum
Definition: postgres.h:372
FmgrInfo * arginfuncs
Definition: plperl.c:200
static void croak_cstr(const char *str)
bool fn_readonly
Definition: plperl.c:116
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
void * palloc(Size size)
Definition: mcxt.c:848
int i
static HV * plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int)
Definition: plperl.c:3161
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
#define PG_TRY()
Definition: elog.h:284
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343
plperl_query_desc * query_data
Definition: plperl.c:209

◆ plperl_spi_execute_fetch_result()

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

Definition at line 3161 of file plperl.c.

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().

3163 {
3164  dTHX;
3165  HV *result;
3166 
3168 
3169  result = newHV();
3170 
3171  hv_store_string(result, "status",
3173  hv_store_string(result, "processed",
3174  (processed > (uint64) UV_MAX) ?
3175  newSVnv((NV) processed) :
3176  newSVuv((UV) processed));
3177 
3178  if (status > 0 && tuptable)
3179  {
3180  AV *rows;
3181  SV *row;
3182  uint64 i;
3183 
3184  /* Prevent overflow in call to av_extend() */
3185  if (processed > (uint64) AV_SIZE_MAX)
3186  ereport(ERROR,
3187  (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED),
3188  errmsg("query result has too many rows to fit in a Perl array")));
3189 
3190  rows = newAV();
3191  av_extend(rows, processed);
3192  for (i = 0; i < processed; i++)
3193  {
3194  row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
3195  av_push(rows, row);
3196  }
3197  hv_store_string(result, "rows",
3198  newRV_noinc((SV *) rows));
3199  }
3200 
3201  SPI_freetuptable(tuptable);
3202 
3203  return result;
3204 }
#define dTHX
Definition: ppport.h:3208
#define AV_SIZE_MAX
Definition: plperl.h:107
int errcode(int sqlerrcode)
Definition: elog.c:575
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3993
HeapTuple * vals
Definition: spi.h:28
NVTYPE NV
Definition: ppport.h:3754
#define ERROR
Definition: elog.h:43
#define newSVuv(uv)
Definition: ppport.h:3596
const char * SPI_result_code_string(int code)
Definition: spi.c:1521
#define ereport(elevel, rest)
Definition: elog.h:122
static SV * plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
Definition: plperl.c:3016
void SPI_freetuptable(SPITupleTable *tuptable)
Definition: spi.c:978
#define newRV_noinc(a)
Definition: ppport.h:4456
TupleDesc tupdesc
Definition: spi.h:27
static SV * cstr2sv(const char *str)
#define UV_MAX
Definition: ppport.h:3566
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
int errmsg(const char *fmt,...)
Definition: elog.c:797
int i
static void static void status(const char *fmt,...) pg_attribute_printf(1
Definition: pg_regress.c:225

◆ plperl_spi_fetchrow()

SV* plperl_spi_fetchrow ( char *  cursor)

Definition at line 3440 of file plperl.c.

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, and SPITupleTable::vals.

3441 {
3442  SV *row;
3443 
3444  /*
3445  * Execute the FETCH inside a sub-transaction, so we can cope with errors
3446  * sanely
3447  */
3448  MemoryContext oldcontext = CurrentMemoryContext;
3450 
3452 
3454  /* Want to run inside function's memory context */
3455  MemoryContextSwitchTo(oldcontext);
3456 
3457  PG_TRY();
3458  {
3459  dTHX;
3461 
3462  if (!p)
3463  {
3464  row = &PL_sv_undef;
3465  }
3466  else
3467  {
3468  SPI_cursor_fetch(p, true, 1);
3469  if (SPI_processed == 0)
3470  {
3471  SPI_cursor_close(p);
3472  row = &PL_sv_undef;
3473  }
3474  else
3475  {
3478  }
3480  }
3481 
3482  /* Commit the inner transaction, return to outer xact context */
3484  MemoryContextSwitchTo(oldcontext);
3485  CurrentResourceOwner = oldowner;
3486  }
3487  PG_CATCH();
3488  {
3489  ErrorData *edata;
3490 
3491  /* Save error info */
3492  MemoryContextSwitchTo(oldcontext);
3493  edata = CopyErrorData();
3494  FlushErrorState();
3495 
3496  /* Abort the inner transaction */
3498  MemoryContextSwitchTo(oldcontext);
3499  CurrentResourceOwner = oldowner;
3500 
3501  /* Punt the error to Perl */
3502  croak_cstr(edata->message);
3503 
3504  /* Can't get here, but keep compiler quiet */
3505  return NULL;
3506  }
3507  PG_END_TRY();
3508 
3509  return row;
3510 }
#define dTHX
Definition: ppport.h:3208
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
SPITupleTable * SPI_tuptable
Definition: spi.c:41
#define PL_sv_undef
Definition: ppport.h:4129
HeapTuple * vals
Definition: spi.h:28
void FlushErrorState(void)
Definition: elog.c:1587
uint64 SPI_processed
Definition: spi.c:39
Portal SPI_cursor_find(const char *name)
Definition: spi.c:1343
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
Definition: type.h:124
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
static SV * plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
Definition: plperl.c:3016
void SPI_freetuptable(SPITupleTable *tuptable)
Definition: spi.c:978
static void croak_cstr(const char *str)
TupleDesc tupdesc
Definition: spi.h:27
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
void SPI_cursor_close(Portal portal)
Definition: spi.c:1411
void SPI_cursor_fetch(Portal portal, bool forward, long count)
Definition: spi.c:1355
#define PG_TRY()
Definition: elog.h:284
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343

◆ plperl_spi_freeplan()

void plperl_spi_freeplan ( char *  query)

Definition at line 3917 of file plperl.c.

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

3918 {
3919  SPIPlanPtr plan;
3920  plperl_query_desc *qdesc;
3921  plperl_query_entry *hash_entry;
3922 
3924 
3925  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3926  HASH_FIND, NULL);
3927  if (hash_entry == NULL)
3928  elog(ERROR, "spi_freeplan: Invalid prepared query passed");
3929 
3930  qdesc = hash_entry->query_data;
3931  if (qdesc == NULL)
3932  elog(ERROR, "spi_freeplan: plperl query_hash value vanished");
3933  plan = qdesc->plan;
3934 
3935  /*
3936  * free all memory before SPI_freeplan, so if it dies, nothing will be
3937  * left over
3938  */
3940  HASH_REMOVE, NULL);
3941 
3942  MemoryContextDelete(qdesc->plan_cxt);
3943 
3944  SPI_freeplan(plan);
3945 }
Definition: plperl.c:206
void MemoryContextDelete(MemoryContext context)
Definition: mcxt.c:200
HTAB * query_hash
Definition: plperl.c:94
SPIPlanPtr plan
Definition: plperl.c:197
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
#define ERROR
Definition: elog.h:43
MemoryContext plan_cxt
Definition: plperl.c:196
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
int SPI_freeplan(SPIPlanPtr plan)
Definition: spi.c:615
#define elog
Definition: elog.h:219
plperl_query_desc * query_data
Definition: plperl.c:209

◆ plperl_spi_prepare()

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

Definition at line 3526 of file plperl.c.

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, plperl_query_desc::plan_cxt, 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.

3527 {
3528  volatile SPIPlanPtr plan = NULL;
3529  volatile MemoryContext plan_cxt = NULL;
3530  plperl_query_desc *volatile qdesc = NULL;
3531  plperl_query_entry *volatile hash_entry = NULL;
3532  MemoryContext oldcontext = CurrentMemoryContext;
3534  MemoryContext work_cxt;
3535  bool found;
3536  int i;
3537 
3539 
3541  MemoryContextSwitchTo(oldcontext);
3542 
3543  PG_TRY();
3544  {
3546 
3547  /************************************************************
3548  * Allocate the new querydesc structure
3549  *
3550  * The qdesc struct, as well as all its subsidiary data, lives in its
3551  * plan_cxt. But note that the SPIPlan does not.
3552  ************************************************************/
3554  "PL/Perl spi_prepare query",
3556  MemoryContextSwitchTo(plan_cxt);
3557  qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc));
3558  snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc);
3559  qdesc->plan_cxt = plan_cxt;
3560  qdesc->nargs = argc;
3561  qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid));
3562  qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo));
3563  qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid));
3564  MemoryContextSwitchTo(oldcontext);
3565 
3566  /************************************************************
3567  * Do the following work in a short-lived context so that we don't
3568  * leak a lot of memory in the PL/Perl function's SPI Proc context.
3569  ************************************************************/
3571  "PL/Perl spi_prepare workspace",
3573  MemoryContextSwitchTo(work_cxt);
3574 
3575  /************************************************************
3576  * Resolve argument type names and then look them up by oid
3577  * in the system cache, and remember the required information
3578  * for input conversion.
3579  ************************************************************/
3580  for (i = 0; i < argc; i++)
3581  {
3582  Oid typId,
3583  typInput,
3584  typIOParam;
3585  int32 typmod;
3586  char *typstr;
3587 
3588  typstr = sv2cstr(argv[i]);
3589  parseTypeString(typstr, &typId, &typmod, false);
3590  pfree(typstr);
3591 
3592  getTypeInputInfo(typId, &typInput, &typIOParam);
3593 
3594  qdesc->argtypes[i] = typId;
3595  fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt);
3596  qdesc->argtypioparams[i] = typIOParam;
3597  }
3598 
3599  /* Make sure the query is validly encoded */
3600  pg_verifymbstr(query, strlen(query), false);
3601 
3602  /************************************************************
3603  * Prepare the plan and check for errors
3604  ************************************************************/
3605  plan = SPI_prepare(query, argc, qdesc->argtypes);
3606 
3607  if (plan == NULL)
3608  elog(ERROR, "SPI_prepare() failed:%s",
3610 
3611  /************************************************************
3612  * Save the plan into permanent memory (right now it's in the
3613  * SPI procCxt, which will go away at function end).
3614  ************************************************************/
3615  if (SPI_keepplan(plan))
3616  elog(ERROR, "SPI_keepplan() failed");
3617  qdesc->plan = plan;
3618 
3619  /************************************************************
3620  * Insert a hashtable entry for the plan.
3621  ************************************************************/
3623  qdesc->qname,
3624  HASH_ENTER, &found);
3625  hash_entry->query_data = qdesc;
3626 
3627  /* Get rid of workspace */
3628  MemoryContextDelete(work_cxt);
3629 
3630  /* Commit the inner transaction, return to outer xact context */
3632  MemoryContextSwitchTo(oldcontext);
3633  CurrentResourceOwner = oldowner;
3634  }
3635  PG_CATCH();
3636  {
3637  ErrorData *edata;
3638 
3639  /* Save error info */
3640  MemoryContextSwitchTo(oldcontext);
3641  edata = CopyErrorData();
3642  FlushErrorState();
3643 
3644  /* Drop anything we managed to allocate */
3645  if (hash_entry)
3647  qdesc->qname,
3648  HASH_REMOVE, NULL);
3649  if (plan_cxt)
3650  MemoryContextDelete(plan_cxt);
3651  if (plan)
3652  SPI_freeplan(plan);
3653 
3654  /* Abort the inner transaction */
3656  MemoryContextSwitchTo(oldcontext);
3657  CurrentResourceOwner = oldowner;
3658 
3659  /* Punt the error to Perl */
3660  croak_cstr(edata->message);
3661 
3662  /* Can't get here, but keep compiler quiet */
3663  return NULL;
3664  }
3665  PG_END_TRY();
3666 
3667  /************************************************************
3668  * Return the query's hash key to the caller.
3669  ************************************************************/
3670  return cstr2sv(qdesc->qname);
3671 }
Definition: fmgr.h:56
Definition: plperl.c:206
void MemoryContextDelete(MemoryContext context)
Definition: mcxt.c:200
HTAB * query_hash
Definition: plperl.c:94
SPIPlanPtr plan
Definition: plperl.c:197
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
Oid * argtypioparams
Definition: plperl.c:201
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
SPIPlanPtr SPI_prepare(const char *src, int nargs, Oid *argtypes)
Definition: spi.c:488
#define ALLOCSET_SMALL_SIZES
Definition: memutils.h:175
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
int snprintf(char *str, size_t count, const char *fmt,...) pg_attribute_printf(3
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
unsigned int Oid
Definition: postgres_ext.h:31
void FlushErrorState(void)
Definition: elog.c:1587
signed int int32
Definition: c.h:284
int SPI_result
Definition: spi.c:42
void pfree(void *pointer)
Definition: mcxt.c:949
#define ERROR
Definition: elog.h:43
const char * SPI_result_code_string(int code)
Definition: spi.c:1521
#define ALLOCSET_DEFAULT_SIZES
Definition: memutils.h:165
int SPI_keepplan(SPIPlanPtr plan)
Definition: spi.c:566
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
Oid * argtypes
Definition: plperl.c:199
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
MemoryContext plan_cxt
Definition: plperl.c:196
void fmgr_info_cxt(Oid functionId, FmgrInfo *finfo, MemoryContext mcxt)
Definition: fmgr.c:132
void getTypeInputInfo(Oid type, Oid *typInput, Oid *typIOParam)
Definition: lsyscache.c:2613
MemoryContext TopMemoryContext
Definition: mcxt.c:43
MemoryContext AllocSetContextCreate(MemoryContext parent, const char *name, Size minContextSize, Size initBlockSize, Size maxBlockSize)
Definition: aset.c:322
void * palloc0(Size size)
Definition: mcxt.c:877
char qname[24]
Definition: plperl.c:195
FmgrInfo * arginfuncs
Definition: plperl.c:200
static void croak_cstr(const char *str)
static SV * cstr2sv(const char *str)
void parseTypeString(const char *str, Oid *typeid_p, int32 *typmod_p, bool missing_ok)
Definition: parse_type.c:815
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
int SPI_freeplan(SPIPlanPtr plan)
Definition: spi.c:615
void * palloc(Size size)
Definition: mcxt.c:848
int i
bool pg_verifymbstr(const char *mbstr, int len, bool noError)
Definition: wchar.c:1866
#define CHECK_FOR_INTERRUPTS()
Definition: miscadmin.h:98
#define elog
Definition: elog.h:219
#define PG_TRY()
Definition: elog.h:284
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343
static char * sv2cstr(SV *sv)
plperl_query_desc * query_data
Definition: plperl.c:209

◆ plperl_spi_query()

SV* plperl_spi_query ( char *  query)

Definition at line 3370 of file plperl.c.

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(), ReleaseCurrentSubTransaction(), RollbackAndReleaseCurrentSubTransaction(), SPI_cursor_open(), SPI_freeplan(), SPI_prepare(), SPI_result, and SPI_result_code_string().

3371 {
3372  SV *cursor;
3373 
3374  /*
3375  * Execute the query inside a sub-transaction, so we can cope with errors
3376  * sanely
3377  */
3378  MemoryContext oldcontext = CurrentMemoryContext;
3380 
3382 
3384  /* Want to run inside function's memory context */
3385  MemoryContextSwitchTo(oldcontext);
3386 
3387  PG_TRY();
3388  {
3389  SPIPlanPtr plan;
3390  Portal portal;
3391 
3392  /* Make sure the query is validly encoded */
3393  pg_verifymbstr(query, strlen(query), false);
3394 
3395  /* Create a cursor for the query */
3396  plan = SPI_prepare(query, 0, NULL);
3397  if (plan == NULL)
3398  elog(ERROR, "SPI_prepare() failed:%s",
3400 
3401  portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
3402  SPI_freeplan(plan);
3403  if (portal == NULL)
3404  elog(ERROR, "SPI_cursor_open() failed:%s",
3406  cursor = cstr2sv(portal->name);
3407 
3408  /* Commit the inner transaction, return to outer xact context */
3410  MemoryContextSwitchTo(oldcontext);
3411  CurrentResourceOwner = oldowner;
3412  }
3413  PG_CATCH();
3414  {
3415  ErrorData *edata;
3416 
3417  /* Save error info */
3418  MemoryContextSwitchTo(oldcontext);
3419  edata = CopyErrorData();
3420  FlushErrorState();
3421 
3422  /* Abort the inner transaction */
3424  MemoryContextSwitchTo(oldcontext);
3425  CurrentResourceOwner = oldowner;
3426 
3427  /* Punt the error to Perl */
3428  croak_cstr(edata->message);
3429 
3430  /* Can't get here, but keep compiler quiet */
3431  return NULL;
3432  }
3433  PG_END_TRY();
3434 
3435  return cursor;
3436 }
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
SPIPlanPtr SPI_prepare(const char *src, int nargs, Oid *argtypes)
Definition: spi.c:488
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
Portal SPI_cursor_open(const char *name, SPIPlanPtr plan, Datum *Values, const char *Nulls, bool read_only)
Definition: spi.c:1037
void FlushErrorState(void)
Definition: elog.c:1587
int SPI_result
Definition: spi.c:42
const char * name
Definition: portal.h:117
#define ERROR
Definition: elog.h:43
const char * SPI_result_code_string(int code)
Definition: spi.c:1521
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
Definition: type.h:124
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
static void croak_cstr(const char *str)
static SV * cstr2sv(const char *str)
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
int SPI_freeplan(SPIPlanPtr plan)
Definition: spi.c:615
bool pg_verifymbstr(const char *mbstr, int len, bool noError)
Definition: wchar.c:1866
#define elog
Definition: elog.h:219
#define PG_TRY()
Definition: elog.h:284
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343

◆ plperl_spi_query_prepared()

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

Definition at line 3801 of file plperl.c.

References plperl_query_desc::arginfuncs, plperl_query_desc::argtypes, plperl_query_desc::argtypioparams, BeginInternalSubTransaction(), check_spi_usage_allowed(), CopyErrorData(), croak_cstr(), cstr2sv(), 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, plperl_query_desc::plan, 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().

3802 {
3803  int i;
3804  char *nulls;
3805  Datum *argvalues;
3806  plperl_query_desc *qdesc;
3807  plperl_query_entry *hash_entry;
3808  SV *cursor;
3809  Portal portal = NULL;
3810 
3811  /*
3812  * Execute the query inside a sub-transaction, so we can cope with errors
3813  * sanely
3814  */
3815  MemoryContext oldcontext = CurrentMemoryContext;
3817 
3819 
3821  /* Want to run inside function's memory context */
3822  MemoryContextSwitchTo(oldcontext);
3823 
3824  PG_TRY();
3825  {
3826  /************************************************************
3827  * Fetch the saved plan descriptor, see if it's o.k.
3828  ************************************************************/
3829  hash_entry = hash_search(plperl_active_interp->query_hash, query,
3830  HASH_FIND, NULL);
3831  if (hash_entry == NULL)
3832  elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
3833 
3834  qdesc = hash_entry->query_data;
3835  if (qdesc == NULL)
3836  elog(ERROR, "spi_query_prepared: plperl query_hash value vanished");
3837 
3838  if (qdesc->nargs != argc)
3839  elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed",
3840  qdesc->nargs, argc);
3841 
3842  /************************************************************
3843  * Set up arguments
3844  ************************************************************/
3845  if (argc > 0)
3846  {
3847  nulls = (char *) palloc(argc);
3848  argvalues = (Datum *) palloc(argc * sizeof(Datum));
3849  }
3850  else
3851  {
3852  nulls = NULL;
3853  argvalues = NULL;
3854  }
3855 
3856  for (i = 0; i < argc; i++)
3857  {
3858  bool isnull;
3859 
3860  argvalues[i] = plperl_sv_to_datum(argv[i],
3861  qdesc->argtypes[i],
3862  -1,
3863  NULL,
3864  &qdesc->arginfuncs[i],
3865  qdesc->argtypioparams[i],
3866  &isnull);
3867  nulls[i] = isnull ? 'n' : ' ';
3868  }
3869 
3870  /************************************************************
3871  * go
3872  ************************************************************/
3873  portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls,
3875  if (argc > 0)
3876  {
3877  pfree(argvalues);
3878  pfree(nulls);
3879  }
3880  if (portal == NULL)
3881  elog(ERROR, "SPI_cursor_open() failed:%s",
3883 
3884  cursor = cstr2sv(portal->name);
3885 
3886  /* Commit the inner transaction, return to outer xact context */
3888  MemoryContextSwitchTo(oldcontext);
3889  CurrentResourceOwner = oldowner;
3890  }
3891  PG_CATCH();
3892  {
3893  ErrorData *edata;
3894 
3895  /* Save error info */
3896  MemoryContextSwitchTo(oldcontext);
3897  edata = CopyErrorData();
3898  FlushErrorState();
3899 
3900  /* Abort the inner transaction */
3902  MemoryContextSwitchTo(oldcontext);
3903  CurrentResourceOwner = oldowner;
3904 
3905  /* Punt the error to Perl */
3906  croak_cstr(edata->message);
3907 
3908  /* Can't get here, but keep compiler quiet */
3909  return NULL;
3910  }
3911  PG_END_TRY();
3912 
3913  return cursor;
3914 }
Definition: plperl.c:206
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
HTAB * query_hash
Definition: plperl.c:94
SPIPlanPtr plan
Definition: plperl.c:197
ErrorData * CopyErrorData(void)
Definition: elog.c:1497
Oid * argtypioparams
Definition: plperl.c:201
ResourceOwner CurrentResourceOwner
Definition: resowner.c:138
void ReleaseCurrentSubTransaction(void)
Definition: xact.c:4242
static MemoryContext MemoryContextSwitchTo(MemoryContext context)
Definition: palloc.h:109
static plperl_interp_desc * plperl_active_interp
Definition: plperl.c:232
Portal SPI_cursor_open(const char *name, SPIPlanPtr plan, Datum *Values, const char *Nulls, bool read_only)
Definition: spi.c:1037
void * hash_search(HTAB *hashp, const void *keyPtr, HASHACTION action, bool *foundPtr)
Definition: dynahash.c:902
void FlushErrorState(void)
Definition: elog.c:1587
int SPI_result
Definition: spi.c:42
void pfree(void *pointer)
Definition: mcxt.c:949
const char * name
Definition: portal.h:117
#define ERROR
Definition: elog.h:43
const char * SPI_result_code_string(int code)
Definition: spi.c:1521
void RollbackAndReleaseCurrentSubTransaction(void)
Definition: xact.c:4276
Definition: type.h:124
Oid * argtypes
Definition: plperl.c:199
MemoryContext CurrentMemoryContext
Definition: mcxt.c:37
uintptr_t Datum
Definition: postgres.h:372
FmgrInfo * arginfuncs
Definition: plperl.c:200
static void croak_cstr(const char *str)
static SV * cstr2sv(const char *str)
bool fn_readonly
Definition: plperl.c:116
#define PG_CATCH()
Definition: elog.h:293
void BeginInternalSubTransaction(const char *name)
Definition: xact.c:4171
static void check_spi_usage_allowed(void)
Definition: plperl.c:3089
void * palloc(Size size)
Definition: mcxt.c:848
int i
plperl_proc_desc * prodesc
Definition: plperl.c:180
#define elog
Definition: elog.h:219
#define PG_TRY()
Definition: elog.h:284
static plperl_call_data * current_call_data
Definition: plperl.c:248
#define PG_END_TRY()
Definition: elog.h:300
char * message
Definition: elog.h:343
plperl_query_desc * query_data
Definition: plperl.c:209

◆ 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 1315 of file plperl.c.

References _sv_to_datum_finfo(), Assert, check_stack_depth(), 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, generate_unaccent_rules::str, sv2cstr(), tupleDesc::tdtypeid, plperl_proc_desc::trftypes, type_is_rowtype(), TYPEFUNC_COMPOSITE, TYPEFUNC_COMPOSITE_DOMAIN, TYPEFUNC_OTHER, and VOIDOID.

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().

1319 {
1320  FmgrInfo tmp;
1321  Oid funcid;
1322 
1323  /* we might recurse */
1325 
1326  *isnull = false;
1327 
1328  /*
1329  * Return NULL if result is undef, or if we're in a function returning
1330  * VOID. In the latter case, we should pay no attention to the last Perl
1331  * statement's result, and this is a convenient means to ensure that.
1332  */
1333  if (!sv || !SvOK(sv) || typid == VOIDOID)
1334  {
1335  /* look up type info if they did not pass it */
1336  if (!finfo)
1337  {
1338  _sv_to_datum_finfo(typid, &tmp, &typioparam);
1339  finfo = &tmp;
1340  }
1341  *isnull = true;
1342  /* must call typinput in case it wants to reject NULL */
1343  return InputFunctionCall(finfo, NULL, typioparam, typmod);
1344  }
1346  return OidFunctionCall1(funcid, PointerGetDatum(sv));
1347  else if (SvROK(sv))
1348  {
1349  /* handle references */
1350  SV *sav = get_perl_array_ref(sv);
1351 
1352  if (sav)
1353  {
1354  /* handle an arrayref */
1355  return plperl_array_to_datum(sav, typid, typmod);
1356  }
1357  else if (SvTYPE(SvRV(sv)) == SVt_PVHV)
1358  {
1359  /* handle a hashref */
1360  Datum ret;
1361  TupleDesc td;
1362  bool isdomain;
1363 
1364  if (!type_is_rowtype(typid))
1365  ereport(ERROR,
1366  (errcode(ERRCODE_DATATYPE_MISMATCH),
1367  errmsg("cannot convert Perl hash to non-composite type %s",
1368  format_type_be(typid))));
1369 
1370  td = lookup_rowtype_tupdesc_domain(typid, typmod, true);
1371  if (td != NULL)
1372  {
1373  /* Did we look through a domain? */
1374  isdomain = (typid != td->tdtypeid);
1375  }
1376  else
1377  {
1378  /* Must be RECORD, try to resolve based on call info */
1379  TypeFuncClass funcclass;
1380 
1381  if (fcinfo)
1382  funcclass = get_call_result_type(fcinfo, &typid, &td);
1383  else
1384  funcclass = TYPEFUNC_OTHER;
1385  if (funcclass != TYPEFUNC_COMPOSITE &&
1386  funcclass != TYPEFUNC_COMPOSITE_DOMAIN)
1387  ereport(ERROR,
1388  (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
1389  errmsg("function returning record called in context "
1390  "that cannot accept type record")));
1391  Assert(td);
1392  isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN);
1393  }
1394 
1395  ret = plperl_hash_to_datum(sv, td);
1396 
1397  if (isdomain)
1398  domain_check(ret, false, typid, NULL, NULL);
1399 
1400  /* Release on the result of get_call_result_type is harmless */
1401  ReleaseTupleDesc(td);
1402 
1403  return ret;
1404  }
1405 
1406  /* Reference, but not reference to hash or array ... */
1407  ereport(ERROR,
1408  (errcode(ERRCODE_DATATYPE_MISMATCH),
1409  errmsg("PL/Perl function must return reference to hash or array")));
1410  return (Datum) 0; /* shut up compiler */
1411  }
1412  else
1413  {
1414  /* handle a string/number */
1415  Datum ret;
1416  char *str = sv2cstr(sv);
1417 
1418  /* did not pass in any typeinfo? look it up */
1419  if (!finfo)
1420  {
1421  _sv_to_datum_finfo(typid, &tmp, &typioparam);
1422  finfo = &tmp;
1423  }
1424 
1425  ret = InputFunctionCall(finfo, str, typioparam, typmod);
1426  pfree(str);
1427 
1428  return ret;
1429  }
1430 }
Definition: fmgr.h:56
List * trftypes
Definition: plperl.c:118
Oid tdtypeid
Definition: tupdesc.h:80
TypeFuncClass get_call_result_type(FunctionCallInfo fcinfo, Oid *resultTypeId, TupleDesc *resultTupleDesc)
Definition: funcapi.c:211
static SV * get_perl_array_ref(SV *sv)
Definition: plperl.c:1146
static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod)
Definition: plperl.c:1248
#define PointerGetDatum(X)
Definition: postgres.h:562
int errcode(int sqlerrcode)
Definition: elog.c:575
char * format_type_be(Oid type_oid)
Definition: format_type.c:94
unsigned int Oid
Definition: postgres_ext.h:31
TupleDesc lookup_rowtype_tupdesc_domain(Oid type_id, int32 typmod, bool noError)
Definition: typcache.c:1674
void pfree(void *pointer)
Definition: mcxt.c:949
#define VOIDOID
Definition: pg_type.h:690
#define ERROR
Definition: elog.h:43
#define OidFunctionCall1(functionId, arg1)
Definition: fmgr.h:623
void check_stack_depth(void)
Definition: postgres.c:3150
static Datum plperl_hash_to_datum(SV *src, TupleDesc td)
Definition: plperl.c:1134
TypeFuncClass
Definition: funcapi.h:155
bool type_is_rowtype(Oid typid)
Definition: lsyscache.c:2405
#define ereport(elevel, rest)
Definition: elog.h:122
uintptr_t Datum
Definition: postgres.h:372
void domain_check(Datum value, bool isnull, Oid domainType, void **extra, MemoryContext mcxt)
Definition: domains.c:327
Datum InputFunctionCall(FmgrInfo *flinfo, char *str, Oid typioparam, int32 typmod)
Definition: fmgr.c:1618
#define Assert(condition)
Definition: c.h:670
Oid get_transform_tosql(Oid typid, Oid langid, List *trftypes)
Definition: lsyscache.c:1893
int errmsg(const char *fmt,...)
Definition: elog.c:797
plperl_proc_desc * prodesc
Definition: plperl.c:180
static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam)
Definition: plperl.c:1292
#define ReleaseTupleDesc(tupdesc)
Definition: tupdesc.h:121
static plperl_call_data * current_call_data
Definition: plperl.c:248
static char * sv2cstr(SV *sv)

◆ plperl_sv_to_literal()

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

Definition at line 1434 of file plperl.c.

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

1435 {
1436  Datum str = CStringGetDatum(fqtypename);
1437  Oid typid = DirectFunctionCall1(regtypein, str);
1438  Oid typoutput;
1439  Datum datum;
1440  bool typisvarlena,
1441  isnull;
1442 
1443  if (!OidIsValid(typid))
1444  ereport(ERROR,
1445  (errcode(ERRCODE_UNDEFINED_OBJECT),
1446  errmsg("lookup failed for type %s", fqtypename)));
1447 
1448  datum = plperl_sv_to_datum(sv,
1449  typid, -1,
1450  NULL, NULL, InvalidOid,
1451  &isnull);
1452 
1453  if (isnull)
1454  return NULL;
1455 
1456  getTypeOutputInfo(typid,
1457  &typoutput, &typisvarlena);
1458 
1459  return OidOutputFunctionCall(typoutput, datum);
1460 }
void getTypeOutputInfo(Oid type, Oid *typOutput, bool *typIsVarlena)
Definition: lsyscache.c:2646
static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, FunctionCallInfo fcinfo, FmgrInfo *finfo, Oid typioparam, bool *isnull)
Definition: plperl.c:1315
int errcode(int sqlerrcode)
Definition: elog.c:575
#define DirectFunctionCall1(func, arg1)
Definition: fmgr.h:585
unsigned int Oid
Definition: postgres_ext.h:31
#define OidIsValid(objectId)
Definition: c.h:576
#define ERROR
Definition: elog.h:43
#define CStringGetDatum(X)
Definition: postgres.h:584
#define ereport(elevel, rest)
Definition: elog.h:122
Datum regtypein(PG_FUNCTION_ARGS)
Definition: regproc.c:1061
uintptr_t Datum
Definition: postgres.h:372
#define InvalidOid
Definition: postgres_ext.h:36
char * OidOutputFunctionCall(Oid functionId, Datum val)
Definition: fmgr.c:1742
int errmsg(const char *fmt,...)
Definition: elog.c:797

◆ plperl_trigger_build_args()

static SV* plperl_trigger_build_args ( FunctionCallInfo  fcinfo)
static

Definition at line 1619 of file plperl.c.

References av, FunctionCallInfoData::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().

1620 {
1621  dTHX;
1622  TriggerData *tdata;
1623  TupleDesc tupdesc;
1624  int i;
1625  char *level;
1626  char *event;
1627  char *relid;
1628  char *when;
1629  HV *hv;
1630 
1631  hv = newHV();
1632  hv_ksplit(hv, 12); /* pre-grow the hash */
1633 
1634  tdata = (TriggerData *) fcinfo->context;
1635  tupdesc = tdata->tg_relation->rd_att;
1636 
1637  relid = DatumGetCString(
1640  )
1641  );
1642 
1643  hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname));
1644  hv_store_string(hv, "relid", cstr2sv(relid));
1645 
1646  if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event))
1647  {
1648  event = "INSERT";
1649  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1650  hv_store_string(hv, "new",
1652  tupdesc));
1653  }
1654  else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event))
1655  {
1656  event = "DELETE";
1657  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1658  hv_store_string(hv, "old",
1660  tupdesc));
1661  }
1662  else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event))
1663  {
1664  event = "UPDATE";
1665  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1666  {
1667  hv_store_string(hv, "old",
1669  tupdesc));
1670  hv_store_string(hv, "new",
1672  tupdesc));
1673  }
1674  }
1675  else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event))
1676  event = "TRUNCATE";
1677  else
1678  event = "UNKNOWN";
1679 
1680  hv_store_string(hv, "event", cstr2sv(event));
1681  hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs));
1682 
1683  if (tdata->tg_trigger->tgnargs > 0)
1684  {
1685  AV *av = newAV();
1686 
1687  av_extend(av, tdata->tg_trigger->tgnargs);
1688  for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
1689  av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i]));
1690  hv_store_string(hv, "args", newRV_noinc((SV *) av));
1691  }
1692 
1693  hv_store_string(hv, "relname",
1695 
1696  hv_store_string(hv, "table_name",
1698 
1699  hv_store_string(hv, "table_schema",
1701 
1702  if (TRIGGER_FIRED_BEFORE(tdata->tg_event))
1703  when = "BEFORE";
1704  else if (TRIGGER_FIRED_AFTER(tdata->tg_event))
1705  when = "AFTER";
1706  else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event))
1707  when = "INSTEAD OF";
1708  else
1709  when = "UNKNOWN";
1710  hv_store_string(hv, "when", cstr2sv(when));
1711 
1712  if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event))
1713  level = "ROW";
1714  else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event))
1715  level = "STATEMENT";
1716  else
1717  level = "UNKNOWN";
1718  hv_store_string(hv, "level", cstr2sv(level));
1719 
1720  return newRV_noinc((SV *) hv);
1721 }
#define dTHX
Definition: ppport.h:3208
fmNodePtr context
Definition: fmgr.h:80
#define DirectFunctionCall1(func, arg1)
Definition: fmgr.h:585
static SV ** hv_store_string(HV *hv, const char *key, SV *val)
Definition: plperl.c:3993
#define TRIGGER_FIRED_AFTER(event)
Definition: trigger.h:137
Datum oidout(PG_FUNCTION_ARGS)
Definition: oid.c:127
#define TRIGGER_FIRED_FOR_STATEMENT(event)
Definition: trigger.h:131
HeapTuple tg_trigtuple
Definition: trigger.h:35