5 files changed, 139 insertions, 2 deletions
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index 31fb212bf17..b6310d76738 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -60,10 +60,10 @@ ifeq ($(PORTNAME), cygwin)
 SHLIB_LINK += -Wl,--export-all-symbols
 endif
 
-REGRESS_OPTS = --dbname=$(PL_TESTDB)
+REGRESS_OPTS = --dbname=$(PL_TESTDB) --dlpath=$(top_builddir)/src/test/regress
 REGRESS = plperl_setup plperl plperl_lc plperl_trigger plperl_shared \
 	plperl_elog plperl_util plperl_init plperlu plperl_array \
-	plperl_call plperl_transaction
+	plperl_call plperl_transaction plperl_env
 # if Perl can support two interpreters in one backend,
 # test plperl-and-plperlu cases
 ifneq ($(PERL),)
diff --git a/src/pl/plperl/expected/plperl_env.out b/src/pl/plperl/expected/plperl_env.out
new file mode 100644
index 00000000000..328a5363421
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_env.out
@@ -0,0 +1,53 @@
+--
+-- Test the environment setting
+--
+-- directory path and dlsuffix are passed to us in environment variables
+\getenv libdir PG_LIBDIR
+\getenv dlsuffix PG_DLSUFFIX
+\set regresslib :libdir '/regress' :dlsuffix
+CREATE FUNCTION get_environ()
+   RETURNS text[]
+   AS :'regresslib', 'get_environ'
+   LANGUAGE C STRICT;
+-- fetch the process environment
+CREATE FUNCTION process_env () RETURNS text[]
+LANGUAGE plpgsql AS
+$$
+
+declare
+   res text[];
+   tmp text[];
+   f record;
+begin
+    for f in select unnest(get_environ()) as t loop
+         tmp := regexp_split_to_array(f.t, '=');
+         if array_length(tmp, 1) = 2 then
+            res := res || tmp;
+         end if;
+    end loop;
+    return res;
+end
+
+$$;
+-- plperl should not be able to affect the process environment
+DO
+$$
+   $ENV{TEST_PLPERL_ENV_FOO} = "shouldfail";
+   untie %ENV;
+   $ENV{TEST_PLPERL_ENV_FOO} = "testval";
+   my $penv = spi_exec_query("select unnest(process_env()) as pe");
+   my %received;
+   for (my $f = 0; $f < $penv->{processed}; $f += 2)
+   {
+      my $k = $penv->{rows}[$f]->{pe};
+      my $v = $penv->{rows}[$f+1]->{pe};
+      $received{$k} = $v;
+   }
+   unless (exists $received{TEST_PLPERL_ENV_FOO})
+   {
+      elog(NOTICE, "environ unaffected")
+   }
+
+$$ LANGUAGE plperl;
+WARNING:  attempted alteration of $ENV{TEST_PLPERL_ENV_FOO} at line 12.
+NOTICE:  environ unaffected
diff --git a/src/pl/plperl/meson.build b/src/pl/plperl/meson.build
index 8d2d72ff37e..6b4fa229c4a 100644
--- a/src/pl/plperl/meson.build
+++ b/src/pl/plperl/meson.build
@@ -94,7 +94,9 @@ tests += {
       'plperl_array',
       'plperl_call',
       'plperl_transaction',
+      'plperl_env',
     ],
+    'regress_args': ['--dlpath', meson.build_root() / 'src/test/regress'],
   },
 }
 
diff --git a/src/pl/plperl/plc_trusted.pl b/src/pl/plperl/plc_trusted.pl
index b326482700e..f1bb9922eb8 100644
--- a/src/pl/plperl/plc_trusted.pl
+++ b/src/pl/plperl/plc_trusted.pl
@@ -30,3 +30,27 @@ require Carp;
 require Carp::Heavy;
 require warnings;
 require feature if $] >= 5.010000;
+
+#<<< protect next line from perltidy so perlcritic annotation works
+package PostgreSQL::InServer::WarnEnv; ## no critic (RequireFilenameMatchesPackage)
+#>>>
+
+use strict;
+use warnings;
+use Tie::Hash;
+our @ISA = qw(Tie::StdHash);
+
+sub STORE  { warn "attempted alteration of \$ENV{$_[1]}"; }
+sub DELETE { warn "attempted deletion of \$ENV{$_[1]}"; }
+sub CLEAR  { warn "attempted clearance of ENV hash"; }
+
+# Remove magic property of %ENV. Changes to this will now not be reflected in
+# the process environment.
+*main::ENV = {%ENV};
+
+# Block %ENV changes from trusted PL/Perl, and warn. We changed %ENV to just a
+# normal hash, yet the application may be expecting the usual Perl %ENV
+# magic. Blocking and warning avoids silent application breakage. The user can
+# untie or otherwise disable this, e.g. if the lost mutation is unimportant
+# and modifying the code to stop that mutation would be onerous.
+tie %main::ENV, 'PostgreSQL::InServer::WarnEnv', %ENV or die $!;
diff --git a/src/pl/plperl/sql/plperl_env.sql b/src/pl/plperl/sql/plperl_env.sql
new file mode 100644
index 00000000000..4108f392d1d
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_env.sql
@@ -0,0 +1,58 @@
+--
+-- Test the environment setting
+--
+
+-- directory path and dlsuffix are passed to us in environment variables
+\getenv libdir PG_LIBDIR
+\getenv dlsuffix PG_DLSUFFIX
+
+\set regresslib :libdir '/regress' :dlsuffix
+
+CREATE FUNCTION get_environ()
+   RETURNS text[]
+   AS :'regresslib', 'get_environ'
+   LANGUAGE C STRICT;
+
+-- fetch the process environment
+
+CREATE FUNCTION process_env () RETURNS text[]
+LANGUAGE plpgsql AS
+$$
+
+declare
+   res text[];
+   tmp text[];
+   f record;
+begin
+    for f in select unnest(get_environ()) as t loop
+         tmp := regexp_split_to_array(f.t, '=');
+         if array_length(tmp, 1) = 2 then
+            res := res || tmp;
+         end if;
+    end loop;
+    return res;
+end
+
+$$;
+
+-- plperl should not be able to affect the process environment
+
+DO
+$$
+   $ENV{TEST_PLPERL_ENV_FOO} = "shouldfail";
+   untie %ENV;
+   $ENV{TEST_PLPERL_ENV_FOO} = "testval";
+   my $penv = spi_exec_query("select unnest(process_env()) as pe");
+   my %received;
+   for (my $f = 0; $f < $penv->{processed}; $f += 2)
+   {
+      my $k = $penv->{rows}[$f]->{pe};
+      my $v = $penv->{rows}[$f+1]->{pe};
+      $received{$k} = $v;
+   }
+   unless (exists $received{TEST_PLPERL_ENV_FOO})
+   {
+      elog(NOTICE, "environ unaffected")
+   }
+
+$$ LANGUAGE plperl;