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

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