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.

diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out
index 29acc1b180a7bde938b5b3480fdeb0d469b7b59c..61325138d7e0ebed9977d32345dac191c9d8ea1c 100644 (file)
--- a/src/pl/plperl/expected/plperl_elog.out
+++ b/src/pl/plperl/expected/plperl_elog.out
@@ -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)
+

diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 9ca83281402cf2c2150813fe7bde656a52718d28..b6dfb96102e8c4e87850725ba1538ce7ffceb9fc 100644 (file)
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -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)

diff --git a/src/pl/plperl/sql/plperl_elog.sql b/src/pl/plperl/sql/plperl_elog.sql
index 47cb742d3fb7ac715f67cdcc10b0981d3927ae1d..4f1c014efbdf2ba59d308a6cf19a771af345dc01 100644 (file)
--- a/src/pl/plperl/sql/plperl_elog.sql
+++ b/src/pl/plperl/sql/plperl_elog.sql
@@ -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();