The attached patch completes (I hope) the work begun by Michael Fuhr in an earlier unapplied patch, and makes strict mode work as recently discussed. I moved the embedded strings out of the calling functions into global macros to try to make the code a little more readable.


Unfortunately we can't have regression tests for this because it relies on a custom variable class.

Illustration of use:

andrew=# set plperl.use_strict = 'true';
SET
andrew=# create function foo() returns text language plperlu as $$ $foo=1; return 'foo';$$; ERROR: creation of Perl function failed: Global symbol "$foo" requires explicit package name at (eval 1) line 1.
andrew=# set plperl.use_strict = 'false';
SET
andrew=# create function foo() returns text language plperlu as $$ $foo=1; return 'foo';$$;
CREATE FUNCTION


cheers

andrew
Index: src/pl/plperl/plperl.c
===================================================================
RCS file: /home/cvsmirror/pgsql/src/pl/plperl/plperl.c,v
retrieving revision 1.90
diff -c -r1.90 plperl.c
*** src/pl/plperl/plperl.c	20 Aug 2005 19:19:21 -0000	1.90
--- src/pl/plperl/plperl.c	24 Aug 2005 00:18:03 -0000
***************
*** 185,241 ****
  	/* We don't need to do anything yet when a new backend starts. */
  }
  
  
  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] } ]); }"
- 	};
- 
  	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);
  
  	plperl_proc_hash = newHV();
--- 185,259 ----
  	/* We don't need to do anything yet when a new backend starts. */
  }
  
+ #define PERLBOOT \
+     "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] } ]); }" \
+     "use strict; " \
+ 	"sub ::mk_strict_unsafefunc {return eval(" \
+ 	"qq[ sub { use strict; $_[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}); " \
+ 	"} "
+ 
+ #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 { return $PLContainer->reval(qq[ " \
+ 	"             sub { $_[0] $_[1]}]); }" \
+ 	"$PLContainer->permit('require');$PLContainer->reval('use strict;');" \
+ 	"$PLContainer->deny('require');" \
+ 	"sub ::mk_strict_safefunc { return $PLContainer->reval(qq[ " \
+ 	"             sub { BEGIN { strict->import(); } $_[0] $_[1]}]); }" \
+ 
+ #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');}]); }" \
  
  static void
  plperl_init_interp(void)
  {
! 	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 , embedding, NULL);
  	perl_run(plperl_interp);
  
  	plperl_proc_hash = newHV();
***************
*** 245,288 ****
  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 */
  
  	safe_version = SvNV(res);
  
--- 263,272 ----
  static void
  plperl_safe_init(void)
  {
  	SV		   *res;
  	double		safe_version;
  
! 	res = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
  
  	safe_version = SvNV(res);
  
***************
*** 294,305 ****
  	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;
--- 278,288 ----
  	if (safe_version < 2.0899 )
  	{
  		/* not safe, so disallow all trusted funcs */
! 		eval_pv(SAFE_BAD, FALSE);
  	}
  	else
  	{
! 		eval_pv(SAFE_OK, FALSE);
  	}
  
  	plperl_safe_init_done = true;
***************
*** 369,375 ****
  	XPUSHs(src);
  	PUTBACK ;
  
! 	count = call_pv("_plperl_to_pg_array", G_SCALAR);
  
  	SPAGAIN ;
  
--- 352,358 ----
  	XPUSHs(src);
  	PUTBACK ;
  
! 	count = call_pv("::_plperl_to_pg_array", G_SCALAR);
  
  	SPAGAIN ;
  
***************
*** 661,666 ****
--- 644,650 ----
  	dSP;
  	SV		   *subref;
  	int			count;
+ 	char       *compile_sub;
  
  	if (trusted && !plperl_safe_init_done)
  	{
***************
*** 680,687 ****
  	 * 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);
  	SPAGAIN;
  
  	if (count != 1)
--- 664,680 ----
  	 * errors properly.  Perhaps it's because there's another level of
  	 * eval inside mksafefunc?
  	 */
! 
! 	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)
---------------------------(end of broadcast)---------------------------
TIP 9: In versions below 8.0, the planner will ignore your desire to
       choose an index scan if your joining column's datatypes do not
       match

Reply via email to