Fix up plperl 'use_strict' so that it can be enabled or disabled on the

fly.  Fix problem with incompletely duplicated setup code.  Andrew Dunstan,
from an idea of Michael Fuhr's.

Author: tglsfdc

src/pl/plperl/expected/plperl_elog.out

@@ -19,10 +19,38 @@ create or replace function perl_warn(text) returns void language plperl as $$
 
 $$;
 select perl_warn('implicit elog via warn');
-NOTICE:  implicit elog via warn at (eval 7) line 4.
+NOTICE:  implicit elog via warn at line 4.
 
  perl_warn 
 -----------
 
 (1 row)
 
+-- test strict mode on/off
+SET plperl.use_strict = true;
+create or replace function uses_global() returns text language plperl as $$
+
+  $global = 1;
+  $other_global = 2;
+  return 'uses_global worked';
+
+$$;
+ERROR:  creation of Perl function failed: Global symbol "$global" requires explicit package name at line 3.
+Global symbol "$other_global" requires explicit package name at line 4.
+select uses_global();
+ERROR:  function uses_global() does not exist
+HINT:  No function matches the given name and argument types. You may need to add explicit type casts.
+SET plperl.use_strict = false;
+create or replace function uses_global() returns text language plperl as $$
+
+  $global = 1;
+  $other_global=2;
+  return 'uses_global worked';
+
+$$;
+select uses_global();
+    uses_global     
+--------------------
+ uses_global worked
+(1 row)
+

src/pl/plperl/plperl.c

@@ -33,7 +33,7 @@
  *	  ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.90 2005/08/20 19:19:21 tgl Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.91 2005/08/24 18:16:56 tgl Exp $
  *
  **********************************************************************/
 
@@ -185,57 +185,88 @@ plperl_init_all(void)
 	/* We don't need to do anything yet when a new backend starts. */
 }
 
+/* Each of these macros must represent a single string literal */
+
+#define PERLBOOT \
+	"SPI::bootstrap(); use vars qw(%_SHARED);" \
+	"sub ::plperl_warn { my $msg = shift; " \
+	"       $msg =~ s/\\(eval \\d+\\) //g; &elog(&NOTICE, $msg); } " \
+	"$SIG{__WARN__} = \\&::plperl_warn; " \
+	"sub ::plperl_die { my $msg = shift; " \
+	"       $msg =~ s/\\(eval \\d+\\) //g; die $msg; } " \
+	"$SIG{__DIE__} = \\&::plperl_die; " \
+	"sub ::mkunsafefunc {" \
+	"      my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
+	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
+	"use strict; " \
+	"sub ::mk_strict_unsafefunc {" \
+	"      my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); " \
+	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; } " \
+	"sub ::_plperl_to_pg_array {" \
+	"  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; " \
+	"  my $res = ''; my $first = 1; " \
+	"  foreach my $elem (@$arg) " \
+	"  { " \
+	"    $res .= ', ' unless $first; $first = undef; " \
+	"    if (ref $elem) " \
+	"    { " \
+	"      $res .= _plperl_to_pg_array($elem); " \
+	"    } " \
+	"    else " \
+	"    { " \
+	"      my $str = qq($elem); " \
+	"      $str =~ s/([\"\\\\])/\\\\$1/g; " \
+	"      $res .= qq(\"$str\"); " \
+	"    } " \
+	"  } " \
+	"  return qq({$res}); " \
+	"} "
+
+#define SAFE_MODULE \
+	"require Safe; $Safe::VERSION"
+
+#define SAFE_OK \
+	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
+	"$PLContainer->permit_only(':default');" \
+	"$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
+	"$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
+	"&spi_query &spi_fetchrow " \
+	"&_plperl_to_pg_array " \
+	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
+	"sub ::mksafefunc {" \
+	"      my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); " \
+	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" \
+	"$PLContainer->permit('require'); $PLContainer->reval('use strict;');" \
+	"$PLContainer->deny('require');" \
+	"sub ::mk_strict_safefunc {" \
+	"      my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); " \
+	"      $@ =~ s/\\(eval \\d+\\) //g if $@; return $ret; }" 
+
+#define SAFE_BAD \
+	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');" \
+	"$PLContainer->permit_only(':default');" \
+	"$PLContainer->share(qw[&elog &ERROR ]);" \
+	"sub ::mksafefunc { return $PLContainer->reval(qq[sub { " \
+	"      elog(ERROR,'trusted Perl functions disabled - " \
+	"      please upgrade Perl Safe module to version 2.09 or later');}]); }" \
+	"sub ::mk_strict_safefunc { return $PLContainer->reval(qq[sub { " \
+	"      elog(ERROR,'trusted Perl functions disabled - " \
+	"      please upgrade Perl Safe module to version 2.09 or later');}]); }"
+
 
 static void
 plperl_init_interp(void)
 {
-	static char	   *loose_embedding[3] = {
-		"", "-e",
-		/* all one string follows (no commas please) */
-		"SPI::bootstrap(); use vars qw(%_SHARED);"
-		"sub ::plperl_warn { my $msg = shift; &elog(&NOTICE, $msg); } "
-		"$SIG{__WARN__} = \\&::plperl_warn; "
-		"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
-		"sub ::_plperl_to_pg_array"
-		"{"
-		"  my $arg = shift; ref $arg eq 'ARRAY' || return $arg; "
-		"  my $res = ''; my $first = 1; "
-		"  foreach my $elem (@$arg) "
-		"  { "
-		"    $res .= ', ' unless $first; $first = undef; "
-		"    if (ref $elem) "
-		"    { "
-		"      $res .= _plperl_to_pg_array($elem); "
-		"    } "
-		"    else "
-		"    { "
-		"      my $str = qq($elem); "
-		"      $str =~ s/([\"\\\\])/\\\\$1/g; "
-		"      $res .= qq(\"$str\"); "
-		"    } "
-		"  } "
-		"  return qq({$res}); "
-		"} "
-	};
-
-
-	static char	   *strict_embedding[3] = {
-		"", "-e",
-		/* all one string follows (no commas please) */
-		"SPI::bootstrap(); use vars qw(%_SHARED);"
-		"sub ::plperl_warn { my $msg = shift; &elog(&NOTICE, $msg); } "
-		"$SIG{__WARN__} = \\&::plperl_warn; "
-		"sub ::mkunsafefunc {return eval("
-		"qq[ sub { use strict; $_[0] $_[1] } ]); }"
+	static char	   *embedding[3] = {
+		"", "-e", PERLBOOT
 	};
 
 	plperl_interp = perl_alloc();
 	if (!plperl_interp)
 		elog(ERROR, "could not allocate Perl interpreter");
 
 	perl_construct(plperl_interp);
-	perl_parse(plperl_interp, plperl_init_shared_libs, 3 ,
-			   (plperl_use_strict ? strict_embedding : loose_embedding), NULL);
+	perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
 	perl_run(plperl_interp);
 
 	plperl_proc_hash = newHV();
@@ -245,44 +276,10 @@ plperl_init_interp(void)
 static void
 plperl_safe_init(void)
 {
-	static char *safe_module =
-	"require Safe; $Safe::VERSION";
-
-	static char *common_safe_ok =
-	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
-	"$PLContainer->permit_only(':default');"
-	"$PLContainer->permit(qw[:base_math !:base_io sort time]);"
-	"$PLContainer->share(qw[&elog &spi_exec_query &return_next "
-	"&spi_query &spi_fetchrow "
-	"&_plperl_to_pg_array "
-	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);"
-			   ;
-
-	static char * strict_safe_ok =
-		"$PLContainer->permit('require');$PLContainer->reval('use strict;');"
-		"$PLContainer->deny('require');"
-		"sub ::mksafefunc { return $PLContainer->reval(qq[ "
-		"             sub { BEGIN { strict->import(); } $_[0] $_[1]}]); }"
-		;
-
-	static char * loose_safe_ok =
-		"sub ::mksafefunc { return $PLContainer->reval(qq[ "
-		"             sub { $_[0] $_[1]}]); }"
-		;
-
-	static char *safe_bad =
-	"use vars qw($PLContainer); $PLContainer = new Safe('PLPerl');"
-	"$PLContainer->permit_only(':default');"
-	"$PLContainer->share(qw[&elog &ERROR ]);"
-	"sub ::mksafefunc { return $PLContainer->reval(qq[sub { "
-	"elog(ERROR,'trusted Perl functions disabled - "
-	"please upgrade Perl Safe module to version 2.09 or later');}]); }"
-			   ;
-
 	SV		   *res;
 	double		safe_version;
 
-	res = eval_pv(safe_module, FALSE);	/* TRUE = croak if failure */
+	res = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
 
 	safe_version = SvNV(res);
 
@@ -294,12 +291,11 @@ plperl_safe_init(void)
 	if (safe_version < 2.0899 )
 	{
 		/* not safe, so disallow all trusted funcs */
-		eval_pv(safe_bad, FALSE);
+		eval_pv(SAFE_BAD, FALSE);
 	}
 	else
 	{
-		eval_pv(common_safe_ok, FALSE);
-		eval_pv((plperl_use_strict ? strict_safe_ok : loose_safe_ok), FALSE);
+		eval_pv(SAFE_OK, FALSE);
 	}
 
 	plperl_safe_init_done = true;
@@ -369,7 +365,7 @@ plperl_convert_to_pg_array(SV *src)
 	XPUSHs(src);
 	PUTBACK ;
 
-	count = call_pv("_plperl_to_pg_array", G_SCALAR);
+	count = call_pv("::_plperl_to_pg_array", G_SCALAR);
 
 	SPAGAIN ;
 
@@ -661,6 +657,7 @@ plperl_create_sub(char *s, bool trusted)
 	dSP;
 	SV		   *subref;
 	int			count;
+	char       *compile_sub;
 
 	if (trusted && !plperl_safe_init_done)
 	{
@@ -680,8 +677,17 @@ plperl_create_sub(char *s, bool trusted)
 	 * errors properly.  Perhaps it's because there's another level of
 	 * eval inside mksafefunc?
 	 */
-	count = perl_call_pv((trusted ? "::mksafefunc" : "::mkunsafefunc"),
-						 G_SCALAR | G_EVAL | G_KEEPERR);
+
+	if (trusted && plperl_use_strict)
+		compile_sub = "::mk_strict_safefunc";
+	else if (plperl_use_strict)
+		compile_sub = "::mk_strict_unsafefunc";
+	else if (trusted)
+		compile_sub = "::mksafefunc";
+	else
+		compile_sub = "::mkunsafefunc";
+
+	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
 	SPAGAIN;
 
 	if (count != 1)

src/pl/plperl/sql/plperl_elog.sql

@@ -18,6 +18,28 @@ $$;
 
 select perl_warn('implicit elog via warn');
 
+-- test strict mode on/off
 
+SET plperl.use_strict = true;
 
+create or replace function uses_global() returns text language plperl as $$
 
+  $global = 1;
+  $other_global = 2;
+  return 'uses_global worked';
+
+$$;
+
+select uses_global();
+
+SET plperl.use_strict = false;
+
+create or replace function uses_global() returns text language plperl as $$
+
+  $global = 1;
+  $other_global=2;
+  return 'uses_global worked';
+
+$$;
+
+select uses_global();