plperl strict mode

The attached patch (submitted for testing and comment) allows turning on
perl strict mode via a GUC setting for plperl/plperlu. (plplerlu users
would be able to turn it off again, but plperl users would not, I think.
Certainly not straightforwardly at least.

In order to protect legacy code, the default is to have strict mode off.

For those who are not perl savvy, strict mode disallows some
quick-and-dirty coding methods that are mostly really hangovers from the
days of perl 4, expecially use of undeclared variables and use of bare
words in circumstances where they might be ambiguous. Turning strict
mode on is a common requirement in corporate coding standards (including
some I have written).

This feature has been requested by several plperl users, as well as
scratching my own itch ;-)

Illustration: with this in postgresql.conf:

custom_variable_classes = 'plperl'
plperl.use_strict = true


it works like this:

andrew=# create or replace function foo() returns text language plperl
as $$ $x = 1; return 'hello'; $$;
CREATE FUNCTION
andrew=# select foo();
ERROR:  creation of Perl function failed: Global symbol "$x" requires
explicit package name at (eval 11) line 1.
andrew=# create or replace function foo() returns text language plperl
as $$ my $x = 1; return 'hello'; $$;
CREATE FUNCTION
andrew=# select foo();
  foo
-------
 hello

Note that in the second case $x is declared as a lexical variable,
whereas in the first (failing) case it is an undeclared global.

There is one problem ... it blew up if I used a context setting of
anything more strict than PGC_USERSET. But rally, that's not good. It
needs to be set at the time we make the functions that set up the
anonymous subs ... i.e. at interpreter startup. Anything later will be
ginored anyway. So I'd like to find a way to do that.

cheers

andrew
Index: plperl.c
===================================================================
RCS file: /projects/cvsroot/pgsql/src/pl/plperl/plperl.c,v
retrieving revision 1.73
diff -c -r1.73 plperl.c
*** plperl.c    6 May 2005 17:24:55 -0000    1.73
--- plperl.c    21 May 2005 20:05:42 -0000
***************
*** 97,102 ****
--- 97,104 ----
  static PerlInterpreter *plperl_interp = NULL;
  static HV  *plperl_proc_hash = NULL;

+ static bool plperl_use_strict = false;
+
  /* this is saved and restored by plperl_call_handler */
  static plperl_proc_desc *plperl_current_prodesc = NULL;

***************
*** 154,159 ****
--- 156,176 ----
      if (!plperl_firstcall)
          return;

+
+     /************************************************************
+      * Get user settings needed before we set up the interpreter
+      ************************************************************/
+
+     DefineCustomBoolVariable(
+         "plperl.use_strict",
+         "If true, will compile trusted and untrusted perl code in strict mode",
+         NULL,
+         &plperl_use_strict,
+         PGC_USERSET,
+         NULL, NULL);
+
+     EmitWarningsOnPlaceholders("plperl");
+
      /************************************************************
       * Create the Perl interpreter
       ************************************************************/
***************
*** 189,211 ****
  static void
  plperl_init_interp(void)
  {
!     static char       *embedding[3] = {
          "", "-e",
!
!         /*
!          * no commas between the next lines please. They are supposed to
!          * be one string
!          */
          "SPI::bootstrap(); use vars qw(%_SHARED);"
          "sub ::mkunsafefunc {return eval(qq[ sub { $_[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, embedding, NULL);
      perl_run(plperl_interp);

      /************************************************************
--- 206,233 ----
  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 ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }"
      };

+     static char       *strict_embedding[3] = {
+         "", "-e",
+         /* all one string follows (no commas please) */
+         "SPI::bootstrap(); use vars qw(%_SHARED);"
+         "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);

      /************************************************************
***************
*** 221,235 ****
      static char *safe_module =
      "require Safe; $Safe::VERSION";

!     static char *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 &DEBUG &LOG "
      "&INFO &NOTICE &WARNING &ERROR %SHARED ]);"
-     "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');"
--- 243,268 ----
      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 &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');"
***************
*** 251,257 ****
       * assume that floating-point comparisons are exact, so use a slightly
       * smaller comparison value.
       */
!     eval_pv((safe_version < 2.0899 ? safe_bad : safe_ok), FALSE);

      plperl_safe_init_done = true;
  }
--- 284,299 ----
       * assume that floating-point comparisons are exact, so use a slightly
       * smaller comparison value.
       */
!     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;
  }