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.
This commit is contained in:
Tom Lane
parent
a06d98bbf4
commit
a62604508f
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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,48 +185,80 @@ 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();
|
||||
|
|
@ -234,8 +266,7 @@ plperl_init_interp(void)
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -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();
|
||||
|
|
|
|||
Loading…
Reference in New Issue