Re: Initial refactoring of plperl.c [PATCH]

I've started work on the enhancements to plperl I outlined on pg-general
(XXX 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.
- Adds a test for the effect of the utf8fix function.

I'd appreciate any feedback on the patch.

The next step I plan is to move the large multi-line string literal
macros (PERLBOOT, SAFE_OK etc) into external perl code files.
That'll make refactoring, extending and maintaining that perl
code far simpler.

A $pkglib_path/perl directory seems an appropriate place for this code.
Assuming that's okay, how should I go about creating that directory and
putting files there during build/installation?

I could implement that and include it as an update to this patch, or as
a new patch on top. Which would be preferable?

Tim.

Tim Bunce <Tim(dot)Bunce(at)pobox(dot)com> writes:
> The next step I plan is to move the large multi-line string literal
> macros (PERLBOOT, SAFE_OK etc) into external perl code files.
> That'll make refactoring, extending and maintaining that perl
> code far simpler.

That does not seem like it accomplishes anything from the user's
perspective except to add more points of failure. To name just one:
would you like to debug a problem that stems from a version mismatch
between plperl.so and the external perl files? I wouldn't.

I can see wanting the *source* to be separate files, but having it as a
compiled constant string in the executable seems like the right thing.

Since this language is obviously going to require Perl to be present at
compile time, running a little Perl script to convert the source into a
C literal wouldn't be a problem AFAICS.

regards, tom lane

On Tue, Nov 24, 2009 at 11:57:06AM -0500, Tom Lane wrote:
> Tim Bunce <Tim(dot)Bunce(at)pobox(dot)com> writes:
> > The next step I plan is to move the large multi-line string literal
> > macros (PERLBOOT, SAFE_OK etc) into external perl code files.
> > That'll make refactoring, extending and maintaining that perl
> > code far simpler.
>
> That does not seem like it accomplishes anything from the user's
> perspective except to add more points of failure. To name just one:
> would you like to debug a problem that stems from a version mismatch
> between plperl.so and the external perl files? I wouldn't.
>
> I can see wanting the *source* to be separate files, but having it as a
> compiled constant string in the executable seems like the right thing.
>
> Since this language is obviously going to require Perl to be present at
> compile time, running a little Perl script to convert the source into a
> C literal wouldn't be a problem AFAICS.

Okay, thanks. I'll take that route.

Tim.

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.

Tim Bunce wrote:
> - Changed MULTIPLICITY check from runtime to compiletime.
> No loads the large Config module.
>

ISTM the trouble with this is that it assumes that the library that we
compile with is the same as the library loaded at runtime. But there is
no guarantee of that at all.

Perhaps we could do this at library load time, so if it's preloaded in
the postmaster we don't have to rerun the check for every backend.

Have you measured the cost involved here? Are we really saving that much?

cheers

andrew

On Sat, Nov 28, 2009 at 09:35:10AM -0500, Andrew Dunstan wrote:
>
> Tim Bunce wrote:
>> - Changed MULTIPLICITY check from runtime to compiletime.
>> No loads the large Config module.
>
> ISTM the trouble with this is that it assumes that the library that we
> compile with is the same as the library loaded at runtime. But there
> is no guarantee of that at all.

It only assumes that the library that we compile with has the same
'architecture' (archname) the library loaded at runtime--and that's a
fundamental assumption of the libperl binary API.

There is no guarantee of binary compatibility in the perl API between
multiplicity and non-multiplicity builds. That's clearly indicated by
'multi' being included in the archname.

It happens to work at the moment only because certain parts of the API
haven't been used yet. For example, the patch I'm working on at the
moment adds:

PL_exit_flags |= PERL_EXIT_DESTRUCT_END;

as part of a fix for bug #5066. PL_exit_flags expands to very different
(and binary incompatible) code for a perl built with multiplicity
compared to without.

(Similarly, another change I'd like to make, given the time, is to
enable use of PERL_NO_GET_CONTEXT. That would reduce the juggling of
global interpreter variables and eliminate the need for functions like
restore_context(). In return it'll eliminate almost all the hidden calls
to pthread_getspecific() for perls built with threads enabled.)

In summary, changing between multiplicity and non-multiplicity libperls
after building postgresql isn't safe or supported.

Tim.

Tim Bunce wrote:
> In summary, changing between multiplicity and non-multiplicity libperls
> after building postgresql isn't safe or supported.
>
>
>

OK, good. Are you adding a check at load time that the library loaded is
what we expect?

cheers

andrew

On Mon, Nov 30, 2009 at 12:50:41PM -0500, Andrew Dunstan wrote:
>
> Tim Bunce wrote:
>> In summary, changing between multiplicity and non-multiplicity libperls
>> after building postgresql isn't safe or supported.
>
> OK, good. Are you adding a check at load time that the library loaded is
> what we expect?

I won't think there's a need. The load will fail with undefined symbols
(or rather it will once the PL_exit_flags |= PERL_EXIT_DESTRUCT_END
change in the next patch gets added).

Tim.

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