aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/pl/plperl/plc_perlboot.pl3
-rw-r--r--src/pl/plperl/plperl.c179
-rw-r--r--src/pl/plperl/sql/plperl_end.sql29
-rw-r--r--src/pl/plperl/sql/plperl_plperlu.sql1
4 files changed, 193 insertions, 19 deletions
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index f0210e54f90..9364a30ece3 100644
--- a/src/pl/plperl/plc_perlboot.pl
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -1,8 +1,7 @@
-# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.4 2010/01/30 01:46:57 adunstan Exp $
PostgreSQL::InServer::Util::bootstrap();
-PostgreSQL::InServer::SPI::bootstrap();
use strict;
use warnings;
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 1a1e264e9d4..97471edc9ba 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.162 2010/01/28 23:06:09 adunstan Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.163 2010/01/30 01:46:57 adunstan Exp $
*
**********************************************************************/
@@ -27,6 +27,7 @@
#include "miscadmin.h"
#include "nodes/makefuncs.h"
#include "parser/parse_type.h"
+#include "storage/ipc.h"
#include "utils/builtins.h"
#include "utils/fmgroids.h"
#include "utils/guc.h"
@@ -138,6 +139,8 @@ static HTAB *plperl_proc_hash = NULL;
static HTAB *plperl_query_hash = NULL;
static bool plperl_use_strict = false;
+static char *plperl_on_perl_init = NULL;
+static bool plperl_ending = false;
/* this is saved and restored by plperl_call_handler */
static plperl_call_data *current_call_data = NULL;
@@ -151,6 +154,8 @@ Datum plperl_validator(PG_FUNCTION_ARGS);
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 Datum plperl_func_handler(PG_FUNCTION_ARGS);
static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
@@ -237,6 +242,14 @@ _PG_init(void)
PGC_USERSET, 0,
NULL, NULL);
+ DefineCustomStringVariable("plperl.on_perl_init",
+ gettext_noop("Perl code to execute when the perl interpreter is initialized."),
+ NULL,
+ &plperl_on_perl_init,
+ NULL,
+ PGC_SIGHUP, 0,
+ NULL, NULL);
+
EmitWarningsOnPlaceholders("plperl");
MemSet(&hash_ctl, 0, sizeof(hash_ctl));
@@ -261,6 +274,37 @@ _PG_init(void)
inited = true;
}
+
+/*
+ * Cleanup perl interpreters, including running END blocks.
+ * Does not fully undo the actions of _PG_init() nor make it callable again.
+ */
+static void
+plperl_fini(int code, Datum arg)
+{
+ elog(DEBUG3, "plperl_fini");
+
+ /*
+ * Disable use of spi_* functions when running END/DESTROY code.
+ * Could be enabled in future, with care, using a transaction
+ * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php
+ */
+ plperl_ending = true;
+
+ /* Only perform perl cleanup if we're exiting cleanly */
+ if (code) {
+ elog(DEBUG3, "plperl_fini: skipped");
+ return;
+ }
+
+ plperl_destroy_interp(&plperl_trusted_interp);
+ plperl_destroy_interp(&plperl_untrusted_interp);
+ plperl_destroy_interp(&plperl_held_interp);
+
+ elog(DEBUG3, "plperl_fini: done");
+}
+
+
#define SAFE_MODULE \
"require Safe; $Safe::VERSION"
@@ -277,6 +321,8 @@ _PG_init(void)
static void
select_perl_context(bool trusted)
{
+ EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
+
/*
* handle simple cases
*/
@@ -288,6 +334,10 @@ select_perl_context(bool trusted)
*/
if (interp_state == INTERP_HELD)
{
+ /* first actual use of a perl interpreter */
+
+ on_proc_exit(plperl_fini, 0);
+
if (trusted)
{
plperl_trusted_interp = plperl_held_interp;
@@ -325,6 +375,22 @@ select_perl_context(bool trusted)
plperl_safe_init();
PL_ppaddr[OP_REQUIRE] = pp_require_safe;
}
+
+ /*
+ * enable access to the database
+ */
+ newXS("PostgreSQL::InServer::SPI::bootstrap",
+ boot_PostgreSQL__InServer__SPI, __FILE__);
+
+ eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE);
+ if (SvTRUE(ERRSV))
+ {
+ ereport(ERROR,
+ (errcode(ERRCODE_INTERNAL_ERROR),
+ errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+ errdetail("While executing PostgreSQL::InServer::SPI::bootstrap")));
+ }
+
}
/*
@@ -361,7 +427,7 @@ plperl_init_interp(void)
PerlInterpreter *plperl;
static int perl_sys_init_done;
- static char *embedding[3] = {
+ static char *embedding[3+2] = {
"", "-e", PLC_PERLBOOT
};
int nargs = 3;
@@ -408,6 +474,12 @@ plperl_init_interp(void)
save_time = loc ? pstrdup(loc) : NULL;
#endif
+ if (plperl_on_perl_init)
+ {
+ embedding[nargs++] = "-e";
+ embedding[nargs++] = plperl_on_perl_init;
+ }
+
/****
* The perl API docs state that PERL_SYS_INIT3 should be called before
* allocating interprters. Unfortunately, on some platforms this fails
@@ -437,6 +509,9 @@ plperl_init_interp(void)
PERL_SET_CONTEXT(plperl);
perl_construct(plperl);
+ /* run END blocks in perl_destruct instead of perl_run */
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+
/*
* Record the original function for the 'require' opcode.
* Ensure it's used for new interpreters.
@@ -446,9 +521,18 @@ plperl_init_interp(void)
else
PL_ppaddr[OP_REQUIRE] = pp_require_orig;
- perl_parse(plperl, plperl_init_shared_libs,
- nargs, embedding, NULL);
- perl_run(plperl);
+ if (perl_parse(plperl, plperl_init_shared_libs,
+ nargs, embedding, NULL) != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_INTERNAL_ERROR),
+ errmsg("while parsing perl initialization"),
+ errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
+
+ if (perl_run(plperl) != 0)
+ ereport(ERROR,
+ (errcode(ERRCODE_INTERNAL_ERROR),
+ errmsg("while running perl initialization"),
+ errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
#ifdef WIN32
@@ -524,6 +608,43 @@ pp_require_safe(pTHX)
static void
+plperl_destroy_interp(PerlInterpreter **interp)
+{
+ if (interp && *interp)
+ {
+ /*
+ * Only a very minimal destruction is performed:
+ * - just call END blocks.
+ *
+ * We could call perl_destruct() but we'd need to audit its
+ * actions very carefully and work-around any that impact us.
+ * (Calling sv_clean_objs() isn't an option because it's not
+ * part of perl's public API so isn't portably available.)
+ * Meanwhile END blocks can be used to perform manual cleanup.
+ */
+
+ PERL_SET_CONTEXT(*interp);
+
+ /* Run END blocks - based on perl's perl_destruct() */
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
+ dJMPENV;
+ int x = 0;
+
+ JMPENV_PUSH(x);
+ PERL_UNUSED_VAR(x);
+ if (PL_endav && !PL_minus_c)
+ call_list(PL_scopestack_ix, PL_endav);
+ JMPENV_POP;
+ }
+ LEAVE;
+ FREETMPS;
+
+ *interp = NULL;
+ }
+}
+
+
+static void
plperl_safe_init(void)
{
SV *safe_version_sv;
@@ -544,8 +665,8 @@ plperl_safe_init(void)
{
ereport(ERROR,
(errcode(ERRCODE_INTERNAL_ERROR),
- errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errdetail("While executing PLC_SAFE_BAD")));
+ errmsg("while executing PLC_SAFE_BAD"),
+ errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
}
}
@@ -556,8 +677,8 @@ plperl_safe_init(void)
{
ereport(ERROR,
(errcode(ERRCODE_INTERNAL_ERROR),
- errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
- errdetail("While executing PLC_SAFE_OK")));
+ errmsg("while executing PLC_SAFE_OK"),
+ errdetail("%s", strip_trailing_ws(SvPV_nolen(ERRSV))) ));
}
if (GetDatabaseEncoding() == PG_UTF8)
@@ -1153,18 +1274,14 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
*
**********************************************************************/
-EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
-EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
-EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
-
static void
plperl_init_shared_libs(pTHX)
{
char *file = __FILE__;
+ EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
+ EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
- newXS("PostgreSQL::InServer::SPI::bootstrap",
- boot_PostgreSQL__InServer__SPI, file);
newXS("PostgreSQL::InServer::Util::bootstrap",
boot_PostgreSQL__InServer__Util, file);
}
@@ -1900,6 +2017,16 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
}
+static void
+check_spi_usage_allowed()
+{
+ if (plperl_ending) {
+ /* simple croak as we don't want to involve PostgreSQL code */
+ croak("SPI functions can not be used in END blocks");
+ }
+}
+
+
HV *
plperl_spi_exec(char *query, int limit)
{
@@ -1912,6 +2039,8 @@ plperl_spi_exec(char *query, int limit)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
@@ -1975,6 +2104,8 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
{
HV *result;
+ check_spi_usage_allowed();
+
result = newHV();
hv_store_string(result, "status",
@@ -2148,6 +2279,8 @@ plperl_spi_query(char *query)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
@@ -2226,6 +2359,8 @@ plperl_spi_fetchrow(char *cursor)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
@@ -2300,7 +2435,11 @@ plperl_spi_fetchrow(char *cursor)
void
plperl_spi_cursor_close(char *cursor)
{
- Portal p = SPI_cursor_find(cursor);
+ Portal p;
+
+ check_spi_usage_allowed();
+
+ p = SPI_cursor_find(cursor);
if (p)
SPI_cursor_close(p);
@@ -2318,6 +2457,8 @@ plperl_spi_prepare(char *query, int argc, SV **argv)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
MemoryContextSwitchTo(oldcontext);
@@ -2453,6 +2594,8 @@ plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
@@ -2595,6 +2738,8 @@ plperl_spi_query_prepared(char *query, int argc, SV **argv)
MemoryContext oldcontext = CurrentMemoryContext;
ResourceOwner oldowner = CurrentResourceOwner;
+ check_spi_usage_allowed();
+
BeginInternalSubTransaction(NULL);
/* Want to run inside function's memory context */
MemoryContextSwitchTo(oldcontext);
@@ -2718,6 +2863,8 @@ plperl_spi_freeplan(char *query)
plperl_query_desc *qdesc;
plperl_query_entry *hash_entry;
+ check_spi_usage_allowed();
+
hash_entry = hash_search(plperl_query_hash, query,
HASH_FIND, NULL);
if (hash_entry == NULL)
diff --git a/src/pl/plperl/sql/plperl_end.sql b/src/pl/plperl/sql/plperl_end.sql
new file mode 100644
index 00000000000..90f49dc6f97
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_end.sql
@@ -0,0 +1,29 @@
+-- test END block handling
+
+-- Not included in the normal testing
+-- because it's beyond the scope of the test harness.
+-- Available here for manual developer testing.
+
+DO $do$
+ my $testlog = "/tmp/pgplperl_test.log";
+
+ warn "Run test, then examine contents of $testlog (which must already exist)\n";
+ return unless -f $testlog;
+
+ use IO::Handle; # for autoflush
+ open my $fh, '>', $testlog
+ or die "Can't write to $testlog: $!";
+ $fh->autoflush(1);
+
+ print $fh "# you should see just 3 'Warn: ...' lines: PRE, END and SPI ...\n";
+ $SIG{__WARN__} = sub { print $fh "Warn: @_" };
+ $SIG{__DIE__} = sub { print $fh "Die: @_" unless $^S; die @_ };
+
+ END {
+ warn "END\n";
+ eval { spi_exec_query("select 1") };
+ warn $@;
+ }
+ warn "PRE\n";
+
+$do$ language plperlu;
diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql
index fc2bb7b8067..15b5aa29687 100644
--- a/src/pl/plperl/sql/plperl_plperlu.sql
+++ b/src/pl/plperl/sql/plperl_plperlu.sql
@@ -16,4 +16,3 @@ $$ LANGUAGE plperlu; -- compile plperlu code
SELECT * FROM bar(); -- throws exception normally (running plperl)
SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
-
generated by cgit v1.2.3 (git 2.25.1) at 2025-05-28 13:06:01 +0000