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)