Thread: PL/Perl regression tests with use_strict
The attached patch allows the PL/Perl regression tests to pass when use_strict is enabled. I've also attached a variant of plperl_elog.out to account for an elog() message that shows a different line number when run under use_strict. -- Michael Fuhr
Attachment
On Sat, Aug 20, 2005 at 01:52:42PM -0600, Michael Fuhr wrote: > The attached patch allows the PL/Perl regression tests to pass when > use_strict is enabled. I've also attached a variant of plperl_elog.out > to account for an elog() message that shows a different line number > when run under use_strict. Here's an updated version of the PL/Perl regression test patch that works with Andrew Dunstan's strict mode patch, both when use_strict is enabled and when it's disabled. The variant of plperl_elog.out is no longer needed. -- Michael Fuhr
Attachment
Michael Fuhr <mike@fuhr.org> writes:
> Here's an updated version of the PL/Perl regression test patch that
> works with Andrew Dunstan's strict mode patch, both when use_strict
> is enabled and when it's disabled. The variant of plperl_elog.out
> is no longer needed.
Actually, the main reason I didn't apply the prior version right
away was that the variant .out file was bugging me. Why does the
error report contain a line number that's dependent on implementation
internals in the first place? Changing it to a different number
doesn't seem like an improvement; can't we get rid of that entirely?
regards, tom lane
On Tue, Aug 23, 2005 at 11:58:25PM -0400, Tom Lane wrote: > Michael Fuhr <mike@fuhr.org> writes: > > Here's an updated version of the PL/Perl regression test patch that > > works with Andrew Dunstan's strict mode patch, both when use_strict > > is enabled and when it's disabled. The variant of plperl_elog.out > > is no longer needed. > > Actually, the main reason I didn't apply the prior version right > away was that the variant .out file was bugging me. Why does the > error report contain a line number that's dependent on implementation > internals in the first place? Changing it to a different number > doesn't seem like an improvement; can't we get rid of that entirely? Actually, I just noticed that the varying number isn't a line number but rather a sequence number. Example: % cat foo #!/usr/bin/perl use strict; use warnings; my $code = '$x = 123;'; eval $code; print $@; eval $code; print $@; eval $code; print $@; % ./foo Global symbol "$x" requires explicit package name at (eval 1) line 1. Global symbol "$x" requires explicit package name at (eval 2) line 1. Global symbol "$x" requires explicit package name at (eval 3) line 1. If I'm reading the Perl source code correctly (pp_ctl.c), the number following "eval" comes from a variable named PL_evalseq that's incremented each time it appears in one of these messages. It looks like we'd have to munge the error message to get rid of that. -- Michael Fuhr
On Tue, Aug 23, 2005 at 10:30:51PM -0600, Michael Fuhr wrote: > Global symbol "$x" requires explicit package name at (eval 3) line 1. > > If I'm reading the Perl source code correctly (pp_ctl.c), the number > following "eval" comes from a variable named PL_evalseq that's > incremented each time it appears in one of these messages. It looks > like we'd have to munge the error message to get rid of that. Hmmm...tests suggest that we might be able to munge $@ in the mk*safefunc functions. That is, instead of doing return eval($stuff); we might be able to do my $retval = eval($stuff); $@ =~ s/ \(eval \d+\) / /g if $@; return $retval; That would convert messages like Global symbol "$x" requires explicit package name at (eval 3) line 1. into Global symbol "$x" requires explicit package name at line 1. Is that what you're looking for? So far I've done only simple tests in standalone embedded Perl programs, so I don't know if this approach would work in PL/Perl or have unintended effects. -- Michael Fuhr
Michael Fuhr said:
> On Tue, Aug 23, 2005 at 10:30:51PM -0600, Michael Fuhr wrote:
>> Global symbol "$x" requires explicit package name at (eval 3) line 1.
>>
>> If I'm reading the Perl source code correctly (pp_ctl.c), the number
>> following "eval" comes from a variable named PL_evalseq that's
>> incremented each time it appears in one of these messages. It looks
>> like we'd have to munge the error message to get rid of that.
>
> Hmmm...tests suggest that we might be able to munge $@ in the
> mk*safefunc functions. That is, instead of doing
>
> return eval($stuff);
>
> we might be able to do
>
> my $retval = eval($stuff);
> $@ =~ s/ \(eval \d+\) / /g if $@;
> return $retval;
>
> That would convert messages like
>
> Global symbol "$x" requires explicit package name at (eval 3) line 1.
>
> into
>
> Global symbol "$x" requires explicit package name at line 1.
>
> Is that what you're looking for? So far I've done only simple tests in
> standalone embedded Perl programs, so I don't know if this approach
> would work in PL/Perl or have unintended effects.
It would probably be more efficient and less convoluted to munge this in a
__DIE__ handler. The we wouldn't need the extra level of eval.
e.g.
$SIG{__DIE__} =
sub { my $msg = $_[0]; $msg =~ s/\(eval \d+\) //; die $msg; };
cheers
andrew
I wrote:
>Michael Fuhr said:
>
>
>>we might be able to do
>>
>> my $retval = eval($stuff);
>> $@ =~ s/ \(eval \d+\) / /g if $@;
>> return $retval;
>>
>>T
>>
>It would probably be more efficient and less convoluted to munge this in a
>__DIE__ handler. The we wouldn't need the extra level of eval.
>
>e.g.
>
>$SIG{__DIE__} =
> sub { my $msg = $_[0]; $msg =~ s/\(eval \d+\) //; die $msg; };
>
>
>
>
Or rather it would do if we didn't carefully avoid the die handler so we
can get our hands on the message.
Here's an updated patch incorporating Michael's ideas, and this time
*with* a small regression test that dynamically turns strict mode on/off.
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 13:41:54 -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+\\)//; &elog(&NOTICE, $msg); } " \
+ "$SIG{__WARN__} = \\&::plperl_warn; " \
+ "sub ::plperl_die { my $msg = shift; " \
+ " $msg =~ s/ \\(eval \\d+\\)//; die $msg; } " \
+ "$SIG{__DIE__} = \\&::plperl_die; " \
+ "sub ::mkunsafefunc { my $ret = eval(qq[ sub { $_[0] $_[1] } ]); " \
+ " $@ =~ s/ \\(eval \\d+\\)// if $@; return $ret; }" \
+ "use strict; " \
+ "sub ::mk_strict_unsafefunc { my $ret = eval(" \
+ " qq[ sub { use strict; $_[0] $_[1] } ]); " \
+ " $@ =~ s/ \\(eval \\d+\\)// 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+\\)// 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+\\)// 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 13:43:17 -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,53 ----
$$;
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;
+ return 'uses_global worked';
+
+ $$;
+ ERROR: creation of Perl function failed: Global symbol "$global" requires explicit package name at line 3.
+ 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;
+ 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 13:39:00 -0000
***************
*** 18,23 ****
--- 18,47 ----
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;
+ 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;
+ return 'uses_global worked';
+
+ $$;
+
+ select uses_global();
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. -- Michael Fuhr
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();
Michael Fuhr <mike@fuhr.org> writes:
> The attached patch allows the PL/Perl regression tests to pass when
> use_strict is enabled. I've also attached a variant of plperl_elog.out
> to account for an elog() message that shows a different line number
> when run under use_strict.
Now that we've got the use_strict mess sorted, I've applied this.
regards, tom lane