Michael Fuhr wrote:
On Wed, Aug 24, 2005 at 09:50:06AM -0400, Andrew Dunstan wrote:
Here's an updated patch incorporating Michael's ideas, and this time
*with* a small regression test that dynamically turns strict mode on/off.
Shouldn't the $@ munging patterns include the /g flag so they remove
all occurrences of the pattern?
SET plperl.use_strict TO on;
CREATE FUNCTION foo() RETURNS integer AS $$
$x = 1;
$y = 2;
return $x + $y;
$$ LANGUAGE plperl;
ERROR: creation of Perl function failed: Global symbol "$x" requires explicit
package name at line 2.
Global symbol "$y" requires explicit package name at (eval 10) line 3.
Global symbol "$x" requires explicit package name at (eval 10) line 4.
Global symbol "$y" requires explicit package name at (eval 10) line 4.
good point.
Here's yet another revision ;-)
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 14:21:56 -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,266 ----
/* 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; " \
+ " $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');}]); }" \
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);
--- 270,279 ----
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;
--- 285,295 ----
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 ;
--- 359,365 ----
XPUSHs(src);
PUTBACK ;
! count = call_pv("::_plperl_to_pg_array", G_SCALAR);
SPAGAIN ;
***************
*** 661,666 ****
--- 651,657 ----
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)
--- 671,687 ----
* 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)
Index: src/pl/plperl/expected/plperl_elog.out
===================================================================
RCS file: /home/cvsmirror/pgsql/src/pl/plperl/expected/plperl_elog.out,v
retrieving revision 1.2
diff -c -r1.2 plperl_elog.out
*** src/pl/plperl/expected/plperl_elog.out 7 Jul 2005 04:41:01 -0000 1.2
--- src/pl/plperl/expected/plperl_elog.out 24 Aug 2005 14:25:06 -0000
***************
*** 19,28 ****
$$;
select perl_warn('implicit elog via warn');
! NOTICE: implicit elog via warn at (eval 7) line 4.
perl_warn
-----------
(1 row)
--- 19,56 ----
$$;
select perl_warn('implicit elog via warn');
! 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)
+
Index: src/pl/plperl/sql/plperl_elog.sql
===================================================================
RCS file: /home/cvsmirror/pgsql/src/pl/plperl/sql/plperl_elog.sql,v
retrieving revision 1.1
diff -c -r1.1 plperl_elog.sql
*** src/pl/plperl/sql/plperl_elog.sql 6 Jul 2005 22:44:49 -0000 1.1
--- src/pl/plperl/sql/plperl_elog.sql 24 Aug 2005 14:22:34 -0000
***************
*** 18,23 ****
--- 18,49 ----
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();
---------------------------(end of broadcast)---------------------------
TIP 6: explain analyze is your friend
