Re: Initial refactoring of plperl.c [PATCH]

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(at)postgresql(dot)org)
> To make changes to your subscription:
> http://www.postgresql.org/mailpref/pgsql-hackers