Re: Initial refactoring of plperl.c [PATCH] - Mailing list pgsql-hackers

I've submitted this patch to the open CommitFest
https://commitfest.postgresql.org/action/patch_view?id=245

Tim.

On Wed, Nov 25, 2009 at 03:36:25PM +0000, Tim Bunce wrote:
> Following on from my earlier draft plperl.c refactoring patch, here's a
> new version that's complete (from my perspective at least).
> 
> I've started work on the enhancements to plperl I outlined on pg-general
> (in the "Wishlist of PL/Perl Enhancements for 8.5" thread).
> I have a working implementation of those changes, plus some performance
> enhancements, that I'm now re-working into a clean set of tested and
> polished patches.
> 
> This patch is a first step that doesn't add any extra functionality.
> It refactors the internals to make adding the extra functionality
> easier (and more clearly visible).
> 
> Changes in this patch:
> 
> - Changed MULTIPLICITY check from runtime to compiletime.
>     No loads the large Config module.
> - Changed plperl_init_interp() to return new interp
>     and not alter the global interp_state
> - Moved plperl_safe_init() call into check_interp().
> - Removed plperl_safe_init_done state variable
>     as interp_state now covers that role.
> - Changed plperl_create_sub() to take a plperl_proc_desc argument.
> - Simplified return value handling in plperl_create_sub.
> - Added a test for the effect of the utf8fix function.
> - Changed perl.com link in the docs to perl.org and tweaked
>     wording to clarify that require, not use, is what's blocked.
> - Moved perl code in large multi-line C string literal macros
>     out to plc_*.pl files.
> - Added a test2macro.pl utility to convert the plc_*.pl files to
>     macros in a perlchunks.h file which is #included
> 
> I'd appreciate any feedback on the patch.
> 
> Tim.
> 

> diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
> index 49631f2..4c26561 100644
> *** a/doc/src/sgml/plperl.sgml
> --- b/doc/src/sgml/plperl.sgml
> ***************
> *** 14,20 ****
>     <para>
>      PL/Perl is a loadable procedural language that enables you to write
>      <productname>PostgreSQL</productname> functions in the 
> !    <ulink url="http://www.perl.com">Perl programming language</ulink>.
>     </para>
>   
>     <para>
> --- 14,20 ----
>     <para>
>      PL/Perl is a loadable procedural language that enables you to write
>      <productname>PostgreSQL</productname> functions in the 
> !    <ulink url="http://www.perl.org">Perl programming language</ulink>.
>     </para>
>   
>     <para>
> *************** SELECT * FROM perl_set();
> *** 298,304 ****
>   use strict;
>   </programlisting>
>      in the function body.  But this only works in <application>PL/PerlU</>
> !    functions, since <literal>use</> is not a trusted operation.  In
>      <application>PL/Perl</> functions you can instead do:
>   <programlisting>
>   BEGIN { strict->import(); }
> --- 298,305 ----
>   use strict;
>   </programlisting>
>      in the function body.  But this only works in <application>PL/PerlU</>
> !    functions, since the <literal>use</> triggers a <literal>require</>
> !    which is not a trusted operation.  In
>      <application>PL/Perl</> functions you can instead do:
>   <programlisting>
>   BEGIN { strict->import(); }
> diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
> index a3c3495..8989b14 100644
> *** a/src/pl/plperl/GNUmakefile
> --- b/src/pl/plperl/GNUmakefile
> *************** PSQLDIR = $(bindir)
> *** 45,50 ****
> --- 45,55 ----
>   
>   include $(top_srcdir)/src/Makefile.shlib
>   
> + plperl.o: perlchunks.h
> + 
> + perlchunks.h: plc_*.pl
> +     $(PERL) text2macro.pl --strip='^(\#.*|\s*)$$' plc_*.pl > perlchunks.htmp
> +     mv perlchunks.htmp perlchunks.h
>   
>   all: all-lib
>   
> *************** submake:
> *** 65,71 ****
>       $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
>   
>   clean distclean maintainer-clean: clean-lib
> !     rm -f SPI.c $(OBJS)
>       rm -rf results
>       rm -f regression.diffs regression.out
>   
> --- 70,76 ----
>       $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
>   
>   clean distclean maintainer-clean: clean-lib
> !     rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
>       rm -rf results
>       rm -f regression.diffs regression.out
>   
> diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
> index c8a8fdb..e9f5324 100644
> *** a/src/pl/plperl/expected/plperl.out
> --- b/src/pl/plperl/expected/plperl.out
> *************** $$ LANGUAGE plperl;
> *** 555,557 ****
> --- 555,564 ----
>   SELECT perl_spi_prepared_bad(4.35) as "double precision";
>   ERROR:  type "does_not_exist" does not exist at line 2.
>   CONTEXT:  PL/Perl function "perl_spi_prepared_bad"
> + --
> + -- Test compilation of unicode regex
> + --
> + CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$
> + # see http://rt.perl.org/rt3/Ticket/Display.html?id=47576
> + return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley
> + $$ LANGUAGE plperl;
> diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
> index ...f4739df .
> *** a/src/pl/plperl/plc_perlboot.pl
> --- b/src/pl/plperl/plc_perlboot.pl
> ***************
> *** 0 ****
> --- 1,50 ----
> + SPI::bootstrap();
> + use vars qw(%_SHARED);
> + 
> + sub ::plperl_warn {
> +     (my $msg = shift) =~ s/\(eval \d+\) //g;
> +     &elog(&NOTICE, $msg);
> + } 
> + $SIG{__WARN__} = \&::plperl_warn; 
> + 
> + sub ::plperl_die {
> +     (my $msg = shift) =~ 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); 
> +     } 
> +     elsif (defined($elem)) { 
> +       my $str = qq($elem); 
> +       $str =~ s/([\"\\])/\\$1/g; 
> +       $res .= qq(\"$str\"); 
> +     } 
> +     else {
> +       $res .= 'NULL' ; 
> +     }
> +   } 
> +   return qq({$res}); 
> + }
> diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
> index ...838ccc6 .
> *** a/src/pl/plperl/plc_safe_bad.pl
> --- b/src/pl/plperl/plc_safe_bad.pl
> ***************
> *** 0 ****
> --- 1,15 ----
> + use vars qw($PLContainer);
> + 
> + $PLContainer = new Safe('PLPerl');
> + $PLContainer->permit_only(':default');
> + $PLContainer->share(qw[&elog &ERROR]);
> + 
> + my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
> + sub ::mksafefunc {
> +   return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
> + }
> + 
> + sub ::mk_strict_safefunc {
> +   return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
> + }
> + 
> diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
> index ...15c6297 .
> *** a/src/pl/plperl/plc_safe_ok.pl
> --- b/src/pl/plperl/plc_safe_ok.pl
> ***************
> *** 0 ****
> --- 1,33 ----
> + 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 &return_next 
> +     &spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
> +     &spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan 
> +     &_plperl_to_pg_array 
> +     &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
> + ]);
> + 
> + # Load strict into the container.
> + # The temporary enabling of the caller opcode here is to work around a
> + # bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
> + # notice. It is quite safe, as caller is informational only, and in any case
> + # we only enable it while we load the 'strict' module.
> + $PLContainer->permit(qw[require caller]);
> + $PLContainer->reval('use strict;');
> + $PLContainer->deny(qw[require caller]); 
> + 
> + sub ::mksafefunc {
> +     my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); 
> +     $@ =~ s/\\(eval \\d+\\) //g if $@;
> +     return $ret;
> + }
> + 
> + sub ::mk_strict_safefunc {
> +     my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
> +     $@ =~ s/\\(eval \\d+\\) //g if $@;
> +     return $ret;
> + }
> diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
> index 4ed4f59..c6037d8 100644
> *** a/src/pl/plperl/plperl.c
> --- b/src/pl/plperl/plperl.c
> ***************
> *** 43,48 ****
> --- 43,51 ----
>   /* perl stuff */
>   #include "plperl.h"
>   
> + /* string literal macros defining chunks of perl code */
> + #include "perlchunks.h"
> + 
>   PG_MODULE_MAGIC;
>   
>   /**********************************************************************
> *************** typedef enum
> *** 125,133 ****
>   } InterpState;
>   
>   static InterpState interp_state = INTERP_NONE;
> - static bool can_run_two = false;
>   
> - static bool plperl_safe_init_done = false;
>   static PerlInterpreter *plperl_trusted_interp = NULL;
>   static PerlInterpreter *plperl_untrusted_interp = NULL;
>   static PerlInterpreter *plperl_held_interp = NULL;
> --- 128,134 ----
> *************** Datum        plperl_call_handler(PG_FUNCTION_A
> *** 147,153 ****
>   Datum        plperl_validator(PG_FUNCTION_ARGS);
>   void        _PG_init(void);
>   
> ! static void plperl_init_interp(void);
>   
>   static Datum plperl_func_handler(PG_FUNCTION_ARGS);
>   static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
> --- 148,154 ----
>   Datum        plperl_validator(PG_FUNCTION_ARGS);
>   void        _PG_init(void);
>   
> ! static PerlInterpreter *plperl_init_interp(void);
>   
>   static Datum plperl_func_handler(PG_FUNCTION_ARGS);
>   static Datum plperl_trigger_handler(PG_FUNCTION_ARGS);
> *************** static plperl_proc_desc *compile_plperl_
> *** 156,166 ****
>   
>   static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
>   static void plperl_init_shared_libs(pTHX);
>   static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
>   static SV  *newSVstring(const char *str);
>   static SV **hv_store_string(HV *hv, const char *key, SV *val);
>   static SV **hv_fetch_string(HV *hv, const char *key);
> ! static SV  *plperl_create_sub(char *proname, char *s, bool trusted);
>   static SV  *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
>   static void plperl_compile_callback(void *arg);
>   static void plperl_exec_callback(void *arg);
> --- 157,168 ----
>   
>   static SV  *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc);
>   static void plperl_init_shared_libs(pTHX);
> + static void plperl_safe_init(void);
>   static HV  *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
>   static SV  *newSVstring(const char *str);
>   static SV **hv_store_string(HV *hv, const char *key, SV *val);
>   static SV **hv_fetch_string(HV *hv, const char *key);
> ! static void plperl_create_sub(plperl_proc_desc *desc, char *s);
>   static SV  *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
>   static void plperl_compile_callback(void *arg);
>   static void plperl_exec_callback(void *arg);
> *************** _PG_init(void)
> *** 226,323 ****
>                                       &hash_ctl,
>                                       HASH_ELEM);
>   
> !     plperl_init_interp();
>   
>       inited = true;
>   }
>   
> - /* 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); " \
> -     "    } " \
> -     "    elsif (defined($elem)) " \
> -     "    { " \
> -     "      my $str = qq($elem); " \
> -     "      $str =~ s/([\"\\\\])/\\\\$1/g; " \
> -     "      $res .= qq(\"$str\"); " \
> -     "    } " \
> -     "    else " \
> -     "    { "\
> -     "      $res .= 'NULL' ; " \
> -     "    } "\
> -     "  } " \
> -     "  return qq({$res}); " \
> -     "} "
> - 
>   #define SAFE_MODULE \
>       "require Safe; $Safe::VERSION"
>   
> - /*
> -  * The temporary enabling of the caller opcode here is to work around a
> -  * bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
> -  * notice. It is quite safe, as caller is informational only, and in any case
> -  * we only enable it while we load the 'strict' module.
> -  */
> - 
> - #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 &spi_cursor_close " \
> -     "&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
> -     "&_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(qw[require caller]); $PLContainer->reval('use strict;');" \
> -     "$PLContainer->deny(qw[require caller]); " \
> -     "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');}]); }"
> - 
> - #define TEST_FOR_MULTI \
> -     "use Config; " \
> -     "$Config{usemultiplicity} eq 'define' or "    \
> -     "($Config{usethreads} eq 'define' " \
> -     " and $Config{useithreads} eq 'define')"
> - 
> - 
>   /********************************************************************
>    *
>    * We start out by creating a "held" interpreter that we can use in
> --- 228,242 ----
>                                       &hash_ctl,
>                                       HASH_ELEM);
>   
> !     plperl_held_interp = plperl_init_interp();
> !     interp_state = INTERP_HELD;
>   
>       inited = true;
>   }
>   
>   #define SAFE_MODULE \
>       "require Safe; $Safe::VERSION"
>   
>   /********************************************************************
>    *
>    * We start out by creating a "held" interpreter that we can use in
> *************** check_interp(bool trusted)
> *** 347,352 ****
> --- 266,273 ----
>           }
>           plperl_held_interp = NULL;
>           trusted_context = trusted;
> +         if (trusted) /* done last to avoid recursion */
> +             plperl_safe_init();
>       }
>       else if (interp_state == INTERP_BOTH ||
>                (trusted && interp_state == INTERP_TRUSTED) ||
> *************** check_interp(bool trusted)
> *** 361,382 ****
>               trusted_context = trusted;
>           }
>       }
> !     else if (can_run_two)
>       {
> !         PERL_SET_CONTEXT(plperl_held_interp);
> !         plperl_init_interp();
>           if (trusted)
> !             plperl_trusted_interp = plperl_held_interp;
>           else
> !             plperl_untrusted_interp = plperl_held_interp;
> !         interp_state = INTERP_BOTH;
>           plperl_held_interp = NULL;
>           trusted_context = trusted;
> !     }
> !     else
> !     {
>           elog(ERROR,
>                "cannot allocate second Perl interpreter on this platform");
>       }
>   }
>   
> --- 282,304 ----
>               trusted_context = trusted;
>           }
>       }
> !     else
>       {
> ! #ifdef MULTIPLICITY
> !         PerlInterpreter *plperl = plperl_init_interp();
>           if (trusted)
> !             plperl_trusted_interp = plperl;
>           else
> !             plperl_untrusted_interp = plperl;
>           plperl_held_interp = NULL;
>           trusted_context = trusted;
> !         interp_state = INTERP_BOTH;
> !         if (trusted) /* done last to avoid recursion */
> !             plperl_safe_init();
> ! #else
>           elog(ERROR,
>                "cannot allocate second Perl interpreter on this platform");
> + #endif
>       }
>   }
>   
> *************** restore_context(bool old_context)
> *** 396,406 ****
>       }
>   }
>   
> ! static void
>   plperl_init_interp(void)
>   {
>       static char *embedding[3] = {
> !         "", "-e", PERLBOOT
>       };
>       int            nargs = 3;
>   
> --- 318,331 ----
>       }
>   }
>   
> ! static PerlInterpreter *
>   plperl_init_interp(void)
>   {
> +     PerlInterpreter *plperl;
> +     static int perl_sys_init_done;
> + 
>       static char *embedding[3] = {
> !         "", "-e", PLC_PERLBOOT
>       };
>       int            nargs = 3;
>   
> *************** plperl_init_interp(void)
> *** 457,487 ****
>        */
>   #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
>       /* only call this the first time through, as per perlembed man page */
> !     if (interp_state == INTERP_NONE)
>       {
>           char       *dummy_env[1] = {NULL};
>   
>           PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
>       }
>   #endif
>   
> !     plperl_held_interp = perl_alloc();
> !     if (!plperl_held_interp)
>           elog(ERROR, "could not allocate Perl interpreter");
>   
> !     perl_construct(plperl_held_interp);
> !     perl_parse(plperl_held_interp, plperl_init_shared_libs,
>                  nargs, embedding, NULL);
> !     perl_run(plperl_held_interp);
> ! 
> !     if (interp_state == INTERP_NONE)
> !     {
> !         SV           *res;
> ! 
> !         res = eval_pv(TEST_FOR_MULTI, TRUE);
> !         can_run_two = SvIV(res);
> !         interp_state = INTERP_HELD;
> !     }
>   
>   #ifdef WIN32
>   
> --- 382,405 ----
>        */
>   #if defined(PERL_SYS_INIT3) && !defined(MYMALLOC)
>       /* only call this the first time through, as per perlembed man page */
> !     if (!perl_sys_init_done)
>       {
>           char       *dummy_env[1] = {NULL};
>   
>           PERL_SYS_INIT3(&nargs, (char ***) &embedding, (char ***) &dummy_env);
> +         perl_sys_init_done = 1;
>       }
>   #endif
>   
> !     plperl = perl_alloc();
> !     if (!plperl)
>           elog(ERROR, "could not allocate Perl interpreter");
>   
> !     PERL_SET_CONTEXT(plperl);
> !     perl_construct(plperl);
> !     perl_parse(plperl, plperl_init_shared_libs,
>                  nargs, embedding, NULL);
> !     perl_run(plperl);
>   
>   #ifdef WIN32
>   
> *************** plperl_init_interp(void)
> *** 524,529 ****
> --- 442,448 ----
>       }
>   #endif
>   
> +     return plperl;
>   }
>   
>   
> *************** plperl_safe_init(void)
> *** 545,555 ****
>       if (safe_version < 2.0899)
>       {
>           /* not safe, so disallow all trusted funcs */
> !         eval_pv(SAFE_BAD, FALSE);
>       }
>       else
>       {
> !         eval_pv(SAFE_OK, FALSE);
>           if (GetDatabaseEncoding() == PG_UTF8)
>           {
>               /*
> --- 464,474 ----
>       if (safe_version < 2.0899)
>       {
>           /* not safe, so disallow all trusted funcs */
> !         eval_pv(PLC_SAFE_BAD, FALSE);
>       }
>       else
>       {
> !         eval_pv(PLC_SAFE_OK, FALSE);
>           if (GetDatabaseEncoding() == PG_UTF8)
>           {
>               /*
> *************** plperl_safe_init(void)
> *** 557,591 ****
>                * the safe container and call it. For some reason not entirely
>                * clear, it prevents errors that can arise from the regex code
>                * later trying to load utf8 modules.
>                */
>               plperl_proc_desc desc;
>               FunctionCallInfoData fcinfo;
> -             SV           *ret;
> -             SV           *func;
> - 
> -             /* make sure we don't call ourselves recursively */
> -             plperl_safe_init_done = true;
>   
> !             /* compile the function */
> !             func = plperl_create_sub("utf8fix",
> !                              "return shift =~ /\\xa9/i ? 'true' : 'false' ;",
> !                                      true);
> ! 
> !             /* set up to call the function with a single text argument 'a' */
> !             desc.reference = func;
>               desc.nargs = 1;
>               desc.arg_is_rowtype[0] = false;
>               fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
>   
>               fcinfo.arg[0] = CStringGetTextDatum("a");
>               fcinfo.argnull[0] = false;
>   
>               /* and make the call */
> !             ret = plperl_call_perl_func(&desc, &fcinfo);
>           }
>       }
> - 
> -     plperl_safe_init_done = true;
>   }
>   
>   /*
> --- 476,504 ----
>                * the safe container and call it. For some reason not entirely
>                * clear, it prevents errors that can arise from the regex code
>                * later trying to load utf8 modules.
> +              * See http://rt.perl.org/rt3/Ticket/Display.html?id=47576
>                */
>               plperl_proc_desc desc;
>               FunctionCallInfoData fcinfo;
>   
> !             desc.proname = "utf8fix";
> !             desc.lanpltrusted = true;
>               desc.nargs = 1;
>               desc.arg_is_rowtype[0] = false;
>               fmgr_info(F_TEXTOUT, &(desc.arg_out_func[0]));
>   
> +             /* compile the function */
> +             plperl_create_sub(&desc,
> +                     "return shift =~ /\\xa9/i ? 'true' : 'false' ;");
> + 
> +             /* set up to call the function with a single text argument 'a' */
>               fcinfo.arg[0] = CStringGetTextDatum("a");
>               fcinfo.argnull[0] = false;
>   
>               /* and make the call */
> !             (void) plperl_call_perl_func(&desc, &fcinfo);
>           }
>       }
>   }
>   
>   /*
> *************** plperl_validator(PG_FUNCTION_ARGS)
> *** 970,989 ****
>    * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
>    * supplied in s, and returns a reference to the closure.
>    */
> ! static SV  *
> ! plperl_create_sub(char *proname, char *s, bool trusted)
>   {
>       dSP;
>       SV           *subref;
>       int            count;
>       char       *compile_sub;
>   
> -     if (trusted && !plperl_safe_init_done)
> -     {
> -         plperl_safe_init();
> -         SPAGAIN;
> -     }
> - 
>       ENTER;
>       SAVETMPS;
>       PUSHMARK(SP);
> --- 883,897 ----
>    * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
>    * supplied in s, and returns a reference to the closure.
>    */
> ! static void
> ! plperl_create_sub(plperl_proc_desc *prodesc, char *s)
>   {
>       dSP;
> +     bool        trusted = prodesc->lanpltrusted;
>       SV           *subref;
>       int            count;
>       char       *compile_sub;
>   
>       ENTER;
>       SAVETMPS;
>       PUSHMARK(SP);
> *************** plperl_create_sub(char *proname, char *s
> *** 1017,1025 ****
>           elog(ERROR, "didn't get a return item from mksafefunc");
>       }
>   
>       if (SvTRUE(ERRSV))
>       {
> -         (void) POPs;
>           PUTBACK;
>           FREETMPS;
>           LEAVE;
> --- 925,934 ----
>           elog(ERROR, "didn't get a return item from mksafefunc");
>       }
>   
> +     subref = POPs;
> + 
>       if (SvTRUE(ERRSV))
>       {
>           PUTBACK;
>           FREETMPS;
>           LEAVE;
> *************** plperl_create_sub(char *proname, char *s
> *** 1028,1057 ****
>                    errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
>       }
>   
> -     /*
> -      * need to make a deep copy of the return. it comes off the stack as a
> -      * temporary.
> -      */
> -     subref = newSVsv(POPs);
> - 
>       if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
>       {
>           PUTBACK;
>           FREETMPS;
>           LEAVE;
> - 
> -         /*
> -          * subref is our responsibility because it is not mortal
> -          */
> -         SvREFCNT_dec(subref);
>           elog(ERROR, "didn't get a code ref");
>       }
>   
>       PUTBACK;
>       FREETMPS;
>       LEAVE;
>   
> !     return subref;
>   }
>   
>   
> --- 937,961 ----
>                    errmsg("%s", strip_trailing_ws(SvPV(ERRSV, PL_na)))));
>       }
>   
>       if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
>       {
>           PUTBACK;
>           FREETMPS;
>           LEAVE;
>           elog(ERROR, "didn't get a code ref");
>       }
>   
> +     /*
> +      * need to make a copy of the return, it comes off the stack as a
> +      * temporary.
> +      */
> +     prodesc->reference = newSVsv(subref);
> + 
>       PUTBACK;
>       FREETMPS;
>       LEAVE;
>   
> !     return;
>   }
>   
>   
> *************** compile_plperl_function(Oid fn_oid, bool
> *** 1731,1739 ****
>   
>           check_interp(prodesc->lanpltrusted);
>   
> !         prodesc->reference = plperl_create_sub(prodesc->proname,
> !                                                proc_source,
> !                                                prodesc->lanpltrusted);
>   
>           restore_context(oldcontext);
>   
> --- 1635,1641 ----
>   
>           check_interp(prodesc->lanpltrusted);
>   
> !         plperl_create_sub(prodesc, proc_source);
>   
>           restore_context(oldcontext);
>   
> diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
> index df17834..292b1c0 100644
> *** a/src/pl/plperl/sql/plperl.sql
> --- b/src/pl/plperl/sql/plperl.sql
> *************** CREATE OR REPLACE FUNCTION perl_spi_prep
> *** 361,363 ****
> --- 361,370 ----
>   $$ LANGUAGE plperl;
>   SELECT perl_spi_prepared_bad(4.35) as "double precision";
>   
> + --
> + -- Test compilation of unicode regex
> + --
> + CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$
> + # see http://rt.perl.org/rt3/Ticket/Display.html?id=47576
> + return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley
> + $$ LANGUAGE plperl;
> diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
> index ...1628e86 .
> *** a/src/pl/plperl/text2macro.pl
> --- b/src/pl/plperl/text2macro.pl
> ***************
> *** 0 ****
> --- 1,98 ----
> + =head1 NAME
> + 
> + text2macro.pl - convert text files into C string-literal macro definitions
> + 
> + =head1 SYNOPSIS
> + 
> +   text2macro [options] file ... > output.h
> + 
> + Options:
> + 
> +   --prefix=S   - add prefix S to the names of the macros
> +   --name=S     - use S as the macro name (assumes only one file)
> +   --strip=S    - don't include lines that match perl regex S
> + 
> + =head1 DESCRIPTION
> + 
> + Reads one or more text files and outputs a corresponding series of C
> + pre-processor macro definitions. Each macro defines a string literal that
> + contains the contents of the corresponding text file. The basename of the text
> + file as capitalized and used as the name of the macro, along with an optional prefix.
> + 
> + =cut
> + 
> + use strict;
> + use warnings;
> + 
> + use Getopt::Long;
> + 
> + GetOptions(
> +     'prefix=s'  => \my $opt_prefix,
> +     'name=s'    => \my $opt_name,
> +     'strip=s'   => \my $opt_strip,
> +     'selftest!' => sub { exit selftest() },
> + ) or exit 1;
> + 
> + die "No text files specified"
> +     unless @ARGV;
> + 
> + print qq{
> + /*
> +  * DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST
> +  * Written by $0 from @ARGV
> +  */
> + };
> + 
> + for my $src_file (@ARGV) {
> + 
> +     (my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x;
> + 
> +     open my $src_fh, $src_file # not 3-arg form
> +         or die "Can't open $src_file: $!";
> + 
> +     printf qq{#define %s%s \\\n},
> +         $opt_prefix || '',
> +         ($opt_name) ? $opt_name : uc $macro;
> +     while (<$src_fh>) {
> +         chomp;
> + 
> +         next if $opt_strip and m/$opt_strip/o;
> + 
> +         # escape the text to suite C string literal rules
> +         s/\\/\\\\/g;
> +         s/"/\\"/g;
> + 
> +         printf qq{"%s\\n" \\\n}, $_;
> +     }
> +     print qq{""\n\n};
> + }
> + 
> + print "/* end */\n";
> + 
> + exit 0;
> + 
> + 
> + sub selftest {
> +     my $tmp = "text2macro_tmp";
> +     my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b};
> + 
> +     open my $fh, ">$tmp.pl" or die;
> +     print $fh $string;
> +     close $fh;
> + 
> +     system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
> +     open $fh, ">>$tmp.c";
> +     print $fh "#include <stdio.h>\n";
> +     print $fh "int main() { puts(X); return 0; }\n";
> +     close $fh;
> +     system("cat -n $tmp.c");
> +     
> +     system("make $tmp") == 0 or die;
> +     open $fh, "./$tmp |" or die;
> +     my $result = <$fh>;
> +     unlink <$tmp.*>;
> + 
> +     warn "Test string: $string\n";
> +     warn "Result     : $result";
> +     die "Failed!" if $result ne "$string\n";
> + }

> 
> -- 
> Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
> To make changes to your subscription:
> http://www.postgresql.org/mailpref/pgsql-hackers