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:
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');
|
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
|
perl_warn
|
||||||
-----------
|
-----------
|
||||||
|
|
||||||
(1 row)
|
(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.
|
* ENHANCEMENTS, OR MODIFICATIONS.
|
||||||
*
|
*
|
||||||
* IDENTIFICATION
|
* 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. */
|
/* 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
|
static void
|
||||||
plperl_init_interp(void)
|
plperl_init_interp(void)
|
||||||
{
|
{
|
||||||
static char *loose_embedding[3] = {
|
static char *embedding[3] = {
|
||||||
"", "-e",
|
"", "-e", PERLBOOT
|
||||||
/* 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();
|
plperl_interp = perl_alloc();
|
||||||
|
@ -234,8 +266,7 @@ plperl_init_interp(void)
|
||||||
elog(ERROR, "could not allocate Perl interpreter");
|
elog(ERROR, "could not allocate Perl interpreter");
|
||||||
|
|
||||||
perl_construct(plperl_interp);
|
perl_construct(plperl_interp);
|
||||||
perl_parse(plperl_interp, plperl_init_shared_libs, 3 ,
|
perl_parse(plperl_interp, plperl_init_shared_libs, 3, embedding, NULL);
|
||||||
(plperl_use_strict ? strict_embedding : loose_embedding), NULL);
|
|
||||||
perl_run(plperl_interp);
|
perl_run(plperl_interp);
|
||||||
|
|
||||||
plperl_proc_hash = newHV();
|
plperl_proc_hash = newHV();
|
||||||
|
@ -245,44 +276,10 @@ plperl_init_interp(void)
|
||||||
static void
|
static void
|
||||||
plperl_safe_init(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;
|
SV *res;
|
||||||
double safe_version;
|
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);
|
safe_version = SvNV(res);
|
||||||
|
|
||||||
|
@ -294,12 +291,11 @@ plperl_safe_init(void)
|
||||||
if (safe_version < 2.0899 )
|
if (safe_version < 2.0899 )
|
||||||
{
|
{
|
||||||
/* not safe, so disallow all trusted funcs */
|
/* not safe, so disallow all trusted funcs */
|
||||||
eval_pv(safe_bad, FALSE);
|
eval_pv(SAFE_BAD, FALSE);
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
eval_pv(common_safe_ok, FALSE);
|
eval_pv(SAFE_OK, FALSE);
|
||||||
eval_pv((plperl_use_strict ? strict_safe_ok : loose_safe_ok), FALSE);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
plperl_safe_init_done = true;
|
plperl_safe_init_done = true;
|
||||||
|
@ -369,7 +365,7 @@ plperl_convert_to_pg_array(SV *src)
|
||||||
XPUSHs(src);
|
XPUSHs(src);
|
||||||
PUTBACK ;
|
PUTBACK ;
|
||||||
|
|
||||||
count = call_pv("_plperl_to_pg_array", G_SCALAR);
|
count = call_pv("::_plperl_to_pg_array", G_SCALAR);
|
||||||
|
|
||||||
SPAGAIN ;
|
SPAGAIN ;
|
||||||
|
|
||||||
|
@ -661,6 +657,7 @@ plperl_create_sub(char *s, bool trusted)
|
||||||
dSP;
|
dSP;
|
||||||
SV *subref;
|
SV *subref;
|
||||||
int count;
|
int count;
|
||||||
|
char *compile_sub;
|
||||||
|
|
||||||
if (trusted && !plperl_safe_init_done)
|
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
|
* errors properly. Perhaps it's because there's another level of
|
||||||
* eval inside mksafefunc?
|
* 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;
|
SPAGAIN;
|
||||||
|
|
||||||
if (count != 1)
|
if (count != 1)
|
||||||
|
|
|
@ -18,6 +18,28 @@ $$;
|
||||||
|
|
||||||
select perl_warn('implicit elog via warn');
|
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