The attached patch (submitted for testing and comment) allows turning on perl strict mode via a GUC setting for plperl/plperlu. (plplerlu users would be able to turn it off again, but plperl users would not, I think. Certainly not straightforwardly at least.

In order to protect legacy code, the default is to have strict mode off.

For those who are not perl savvy, strict mode disallows some quick-and-dirty coding methods that are mostly really hangovers from the days of perl 4, expecially use of undeclared variables and use of bare words in circumstances where they might be ambiguous. Turning strict mode on is a common requirement in corporate coding standards (including some I have written).

This feature has been requested by several plperl users, as well as scratching my own itch ;-)

Illustration: with this in postgresql.conf:

custom_variable_classes = 'plperl'
plperl.use_strict = true


it works like this:

andrew=# create or replace function foo() returns text language plperl as $$ $x = 1; return 'hello'; $$;
CREATE FUNCTION
andrew=# select foo();
ERROR: creation of Perl function failed: Global symbol "$x" requires explicit package name at (eval 11) line 1. andrew=# create or replace function foo() returns text language plperl as $$ my $x = 1; return 'hello'; $$;
CREATE FUNCTION
andrew=# select foo();
foo -------
hello

Note that in the second case $x is declared as a lexical variable, whereas in the first (failing) case it is an undeclared global.

There is one problem ... it blew up if I used a context setting of anything more strict than PGC_USERSET. But rally, that's not good. It needs to be set at the time we make the functions that set up the anonymous subs ... i.e. at interpreter startup. Anything later will be ginored anyway. So I'd like to find a way to do that.

cheers

andrew
Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql/src/pl/plperl/plperl.c,v
retrieving revision 1.73
diff -c -r1.73 plperl.c
*** plperl.c	6 May 2005 17:24:55 -0000	1.73
--- plperl.c	21 May 2005 20:05:42 -0000
***************
*** 97,102 ****
--- 97,104 ----
  static PerlInterpreter *plperl_interp = NULL;
  static HV  *plperl_proc_hash = NULL;
  
+ static bool plperl_use_strict = false;
+ 
  /* this is saved and restored by plperl_call_handler */
  static plperl_proc_desc *plperl_current_prodesc = NULL;
  
***************
*** 154,159 ****
--- 156,176 ----
  	if (!plperl_firstcall)
  		return;
  
+ 	
+ 	/************************************************************
+ 	 * Get user settings needed before we set up the interpreter
+ 	 ************************************************************/
+ 
+     DefineCustomBoolVariable(
+         "plperl.use_strict",
+         "If true, will compile trusted and untrusted perl code in strict mode",
+         NULL,
+         &plperl_use_strict,
+         PGC_USERSET,
+         NULL, NULL);
+ 
+     EmitWarningsOnPlaceholders("plperl"); 
+ 	
  	/************************************************************
  	 * Create the Perl interpreter
  	 ************************************************************/
***************
*** 189,211 ****
  static void
  plperl_init_interp(void)
  {
! 	static char	   *embedding[3] = {
  		"", "-e",
! 
! 		/*
! 		 * no commas between the next lines please. They are supposed to
! 		 * be one string
! 		 */
  		"SPI::bootstrap(); use vars qw(%_SHARED);"
  		"sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
  	};
  
  	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, embedding, NULL);
  	perl_run(plperl_interp);
  
  	/************************************************************
--- 206,233 ----
  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 ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
  	};
  
+ 	static char	   *strict_embedding[3] = {
+ 		"", "-e",
+ 		/* all one string follows (no commas please) */
+ 		"SPI::bootstrap(); use vars qw(%_SHARED);"
+ 		"sub ::mkunsafefunc {return eval("
+ 		"qq[ sub { use strict; $_[0] $_[1] } ]); }"
+ 	};
+ 
  	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_run(plperl_interp);
  
  	/************************************************************
***************
*** 221,235 ****
  	static char *safe_module =
  	"require Safe; $Safe::VERSION";
  
! 	static char *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 &DEBUG &LOG "
      "&INFO &NOTICE &WARNING &ERROR %SHARED ]);"
- 	"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');"
--- 243,268 ----
  	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 &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');"
***************
*** 251,257 ****
  	 * assume that floating-point comparisons are exact, so use a slightly
  	 * smaller comparison value.
  	 */
! 	eval_pv((safe_version < 2.0899 ? safe_bad : safe_ok), FALSE);
  
  	plperl_safe_init_done = true;
  }
--- 284,299 ----
  	 * assume that floating-point comparisons are exact, so use a slightly
  	 * smaller comparison value.
  	 */
! 	if (safe_version < 2.0899 )
! 	{
! 		/* not safe, so disallow all trusted funcs */
! 		eval_pv(safe_bad, FALSE);
! 	}
! 	else
! 	{
! 		eval_pv(common_safe_ok, FALSE);
! 		eval_pv((plperl_use_strict ? strict_safe_ok : loose_safe_ok), FALSE);
! 	}
  
  	plperl_safe_init_done = true;
  }
---------------------------(end of broadcast)---------------------------
TIP 3: if posting/reading through Usenet, please send an appropriate
      subscribe-nomail command to [EMAIL PROTECTED] so that your
      message can get through to the mailing list cleanly

Reply via email to