plperl strict mode and associated fixes - Mailing list pgsql-patches

The attached patch completes (I hope) the work begun by Michael Fuhr in
an earlier unapplied patch, and makes strict mode work as recently
discussed. I moved the embedded strings out of the calling functions
into global macros to try to make the code a little more readable.

Unfortunately we can't have regression tests for this because it relies
on a custom variable class.

Illustration of use:

andrew=# set plperl.use_strict = 'true';
SET
andrew=# create function foo() returns text language plperlu as $$
$foo=1; return 'foo';$$;
ERROR:  creation of Perl function failed: Global symbol "$foo" requires
explicit package name at (eval 1) line 1.
andrew=# set plperl.use_strict = 'false';
SET
andrew=# create function foo() returns text language plperlu as $$
$foo=1; return 'foo';$$;
CREATE FUNCTION


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 00:18:03 -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,259 ----
      /* 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; &elog(&NOTICE, $msg); } "  \
+     "$SIG{__WARN__} = \\&::plperl_warn; " \
+     "sub ::mkunsafefunc {return eval(qq[ sub { $_[0] $_[1] } ]); }" \
+     "use strict; " \
+     "sub ::mk_strict_unsafefunc {return eval(" \
+     "qq[ sub { use strict; $_[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}); " \
+     "} "
+
+ #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 { return $PLContainer->reval(qq[ " \
+     "             sub { $_[0] $_[1]}]); }" \
+     "$PLContainer->permit('require');$PLContainer->reval('use strict;');" \
+     "$PLContainer->deny('require');" \
+     "sub ::mk_strict_safefunc { return $PLContainer->reval(qq[ " \
+     "             sub { BEGIN { strict->import(); } $_[0] $_[1]}]); }" \
+
+ #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);

--- 263,272 ----
  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;
--- 278,288 ----
      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 ;

--- 352,358 ----
      XPUSHs(src);
      PUTBACK ;

!     count = call_pv("::_plperl_to_pg_array", G_SCALAR);

      SPAGAIN ;

***************
*** 661,666 ****
--- 644,650 ----
      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)
--- 664,680 ----
       * 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)