Re: PL/Perl regression tests with use_strict - Mailing list pgsql-patches

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();