diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml index 37114bd..4658cc6 100644 *** a/doc/src/sgml/plperl.sgml --- b/doc/src/sgml/plperl.sgml *************** $$ LANGUAGE plperl; *** 141,153 **** CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$ ! my ($x,$y) = @_; ! if (! defined $x) { ! if (! defined $y) { return undef; } return $y; } ! if (! defined $y) { return $x; } ! if ($x > $y) { return $x; } return $y; $$ LANGUAGE plperl; --- 141,153 ---- CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$ ! my ($x, $y) = @_; ! if (not defined $x) { ! return undef if not defined $y; return $y; } ! return $x if not defined $y; ! return $x if $x > $y; return $y; $$ LANGUAGE plperl; *************** $$ LANGUAGE plperl; *** 163,189 **** ordinary numeric or text types, Perl will just do the right thing and the programmer will normally not have to worry about it. However, in other cases the argument will need to be converted into a form that is ! more usable in Perl. For example, here is how to convert an argument of ! type bytea into unescaped binary ! data: ! ! ! my $arg = shift; ! $arg =~ s!\\(?:\\|(\d{3}))!$1 ? chr(oct($1)) : "\\"!ge; ! ! Similarly, values passed back to PostgreSQL ! must be in the external text representation format. For example, here ! is how to escape binary data for a return value of type bytea: ! ! ! $retval =~ s!(\\|[^ -~])!sprintf("\\%03o",ord($1))!ge; ! return $retval; ! ! --- 163,178 ---- ordinary numeric or text types, Perl will just do the right thing and the programmer will normally not have to worry about it. However, in other cases the argument will need to be converted into a form that is ! more usable in Perl. For example, the decode_bytea ! function can be used to convert an argument of ! type bytea into unescaped binary. Similarly, values passed back to PostgreSQL ! must be in the external text representation format. For example, the ! encode_bytea function can be used to ! to escape binary data for a return value of type bytea. *************** SELECT * FROM perl_set(); *** 296,328 **** ! If you wish to use the strict pragma with your code, ! the easiest way to do so is to SET ! plperl.use_strict to true. This parameter affects ! subsequent compilations of PL/Perl functions, but not ! functions already compiled in the current session. To set the ! parameter before PL/Perl has been loaded, it is ! necessary to have added plperl to the list in ! postgresql.conf. ! Another way to use the strict pragma is to put: use strict; ! in the function body. But this only works in PL/PerlU ! functions, since the use triggers a require ! which is not a trusted operation. In ! PL/Perl functions you can instead do: ! ! BEGIN { strict->import(); } ! ! Database Access from PL/Perl --- 285,325 ---- ! If you wish to use the strict pragma with your code you have a few options. ! For temporary global use you can SET plperl.use_strict ! to true (see ). ! This will affect subsequent compilations of PL/Perl ! functions, but not functions already compiled in the current session. ! For permanent global use you can set plperl.use_strict ! to true in the postgresql.conf file. ! For permanent use in specific functions you can simply put: use strict; ! at the top of the function body. ! ! Data Values in PL/Perl ! ! ! The argument values supplied to a PL/Perl function's code are ! simply the input arguments converted to text form (just as if they ! had been displayed by a SELECT statement). ! Conversely, the return and return_next ! commands will accept any string that is acceptable input format ! for the function's declared return type. ! ! ! ! ! Built-in Functions ! ! Database Access from PL/Perl *************** SELECT done(); *** 516,522 **** --- 513,525 ---- + + + + + Utility functions in PL/Perl + elog *************** SELECT done(); *** 545,566 **** - ! ! Data Values in PL/Perl - - The argument values supplied to a PL/Perl function's code are - simply the input arguments converted to text form (just as if they - had been displayed by a SELECT statement). - Conversely, the return command will accept any string - that is acceptable input format for the function's declared return - type. So, within the PL/Perl function, - all values are just text strings. - --- 548,674 ---- + + + + quote_literal + in PL/Perl + + + quote_literal(string) + + + Return the given string suitably quoted to be used as a string literal in an SQL + statement string. Embedded single-quotes and backslashes are properly doubled. + Note that quote_literal returns undef on undef input; if the argument + might be undef, quote_nullable is often more suitable. + + + + + + + quote_nullable + in PL/Perl + + + quote_nullable(string) + + + Return the given string suitably quoted to be used as a string literal in an SQL + statement string; or, if the argument is undef, return the unquoted string "NULL". + Embedded single-quotes and backslashes are properly doubled. + + + + + + + decode_bytea + in PL/Perl + + + decode_bytea(string) + + + Return the unescaped binary data represented by the contents of the given string, + which should be bytea encoded. + + + + + + + encode_bytea + in PL/Perl + + + encode_bytea(string) + + + Return the bytea encoded form of the binary data contents of the given string. + + + + + + + encode_array_literal + in PL/Perl + + + encode_array_literal(array) + encode_array_literal(array, delimiter) + + + Returns the contents of the referenced array as a string in array literal format + (see ). + Returns the argument value if it's not a reference to an array. + The delimiter used between elements of the array literal defaults to ", " + if a delimiter is not specified or is undef. + + + + + + + encode_array_constructor + in PL/Perl + + + encode_array_constructor(array) + + + Returns the contents of the referenced array as a string in array constructor format + (see ). + Individual values are quoted using quote_nullable. + Returns the argument value, quoted using quote_nullable, + if it's not a reference to an array. + + + + + + + looks_like_number + in PL/Perl + + + looks_like_number(string) + + + Returns a true value if the content of the given string looks like a number, + returns false otherwise. Returns undef if the argument is undef. + Leading and trailing space is ignored. + + + + ! *************** CREATE OR REPLACE FUNCTION get_var(name *** 587,593 **** return $_SHARED{$_[0]}; $$ LANGUAGE plperl; ! SELECT set_var('sample', 'Hello, PL/Perl! How's tricks?'); SELECT get_var('sample'); --- 695,701 ---- return $_SHARED{$_[0]}; $$ LANGUAGE plperl; ! SELECT set_var('sample', 'Hello, PL/Perl! How''s tricks?'); SELECT get_var('sample'); *************** $$ LANGUAGE plperl; *** 703,714 **** not start a second interpreter, but instead create an error. In consequence, in such an installation, you cannot use both PL/PerlU and PL/Perl in the same backend ! process. The remedy for this is to obtain a Perl installation created ! with the appropriate flags, namely either usemultiplicity or ! both usethreads and useithreads. ! For more details,see the perlembed manual page. --- 811,827 ---- not start a second interpreter, but instead create an error. In consequence, in such an installation, you cannot use both PL/PerlU and PL/Perl in the same backend ! process. The remedy for this is to obtain a Perl installation configured ! with the appropriate flags, namely either usemultiplicity ! or useithreads. usemultiplicity is preferred ! unless you actually need to use threads. For more details, see the ! perlembed man page. + + + The plperl and plperlu languages have separate %_SHARED variables. + *************** CREATE TRIGGER test_valid_id_trig *** 898,904 **** ! Limitations and Missing Features --- 1011,1102 ---- ! ! PL/Perl Under the Hood ! ! ! Configuration ! ! ! This section lists configuration parameters that affect PL/Perl. ! To set any of these parameters before PL/Perl has been loaded, ! it is necessary to have added plperl to the ! list in ! postgresql.conf. ! ! ! ! ! ! plperl.on_perl_init (string) ! ! plperl.on_perl_init configuration parameter ! ! ! ! Specifies perl code to be executed when a perl interpreter is first initialized. ! Initialization will happen in the postmaster if the plperl library is included ! in shared_preload_libraries (see ), ! in which case extra care should be taken. ! The SPI functions are not available when this code is executed. ! If the code fails with an error it will abort the initialization of the interpreter ! and propagate out to the calling query, causing the current transaction ! or subtransaction to be aborted. ! Only superusers can change this setting. ! Changes made after a perl interpreter has been initialized will have ! no effect on that interpreter. ! ! ! ! ! ! plperl.on_trusted_init (string) ! ! plperl.on_trusted_init configuration parameter ! ! ! ! Specifies perl code to be executed when the plperl perl interpreter ! is first initialized in a session. The perl code can only perform trusted operations. ! The SPI functions are not available when this code is executed. ! Changes made after a plperl perl interpreter has been initialized will have no effect. ! If the code fails with an error it is reported as a WARNING. ! ! ! ! ! ! plperl.on_untrusted_init (string) ! ! plperl.on_untrusted_init configuration parameter ! ! ! ! Specifies perl code to be executed when the plperlu perl interpreter ! is first initialized in a session. ! The SPI functions are not available when this code is executed. ! Changes made after a plperlu perl interpreter has been initialized will have no effect. ! If the code fails with an error it is reported as a WARNING. ! ! ! ! ! ! plperl.use_strict (boolean) ! ! plperl.use_strict configuration parameter ! ! ! ! When set true subsequent compilations of PL/Perl functions have the strict pragma enabled. ! This parameter does not affect functions already compiled in the current session. ! ! ! ! ! ! ! Limitations and Missing Features *************** CREATE TRIGGER test_valid_id_trig *** 908,915 **** ! PL/Perl functions cannot call each other directly (because they ! are anonymous subroutines inside Perl). --- 1106,1112 ---- ! PL/Perl functions cannot call each other directly. *************** CREATE TRIGGER test_valid_id_trig *** 938,943 **** --- 1135,1142 ---- + + diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile index 8989b14..b5dddeb 100644 *** a/src/pl/plperl/GNUmakefile --- b/src/pl/plperl/GNUmakefile *************** rpathdir = $(perl_archlibexp)/CORE *** 34,45 **** NAME = plperl ! OBJS = plperl.o spi_internal.o SPI.o SHLIB_LINK = $(perl_embed_ldflags) REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl ! REGRESS = plperl plperl_trigger plperl_shared plperl_elog # where to find psql for running the tests PSQLDIR = $(bindir) --- 34,45 ---- NAME = plperl ! OBJS = plperl.o SPI.o Util.o SHLIB_LINK = $(perl_embed_ldflags) REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl ! REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util # where to find psql for running the tests PSQLDIR = $(bindir) *************** include $(top_srcdir)/src/Makefile.shlib *** 48,54 **** 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 --- 48,54 ---- 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 *************** all: all-lib *** 56,61 **** --- 56,64 ---- SPI.c: SPI.xs $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ + Util.c: Util.xs + $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ + install: all installdirs install-lib installdirs: installdirs-lib diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs index 967ac0a..af71414 100644 *** a/src/pl/plperl/SPI.xs --- b/src/pl/plperl/SPI.xs *************** *** 8,47 **** /* - * Implementation of plperl's elog() function - * - * If the error level is less than ERROR, we'll just emit the message and - * return. When it is ERROR, elog() will longjmp, which we catch and - * turn into a Perl croak(). Note we are assuming that elog() can't have - * any internal failures that are so bad as to require a transaction abort. - * - * This is out-of-line to suppress "might be clobbered by longjmp" warnings. - */ - static void - do_spi_elog(int level, char *message) - { - MemoryContext oldcontext = CurrentMemoryContext; - - PG_TRY(); - { - elog(level, "%s", message); - } - PG_CATCH(); - { - ErrorData *edata; - - /* Must reset elog.c's state */ - MemoryContextSwitchTo(oldcontext); - edata = CopyErrorData(); - FlushErrorState(); - - /* Punt the error to Perl */ - croak("%s", edata->message); - } - PG_END_TRY(); - } - - /* * Interface routine to catch ereports and punt them to Perl */ static void --- 8,13 ---- *************** do_plperl_return_next(SV *sv) *** 69,108 **** } ! MODULE = SPI PREFIX = spi_ PROTOTYPES: ENABLE VERSIONCHECK: DISABLE - void - spi_elog(level, message) - int level - char* message - CODE: - if (level > ERROR) /* no PANIC allowed thanks */ - level = ERROR; - if (level < DEBUG5) - level = DEBUG5; - do_spi_elog(level, message); - - int - spi_DEBUG() - - int - spi_LOG() - - int - spi_INFO() - - int - spi_NOTICE() - - int - spi_WARNING() - - int - spi_ERROR() - SV* spi_spi_exec_query(query, ...) char* query; --- 35,45 ---- } ! MODULE = PostgreSQL::InServer::SPI PREFIX = spi_ PROTOTYPES: ENABLE VERSIONCHECK: DISABLE SV* spi_spi_exec_query(query, ...) char* query; diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs index ...f502893 . *** a/src/pl/plperl/Util.xs --- b/src/pl/plperl/Util.xs *************** *** 0 **** --- 1,202 ---- + /* vim: et:sw=4 + * + * PostgreSQL::InServer::Util + * + * Defines interfaces for general-purpose utilities. + * This module is bootstrapped as soon as an interpreter is initialized. + * (The SPI module is bootstrapped after the plperl.on_*_init code has run.) + * Currently doesn't define a PACKAGE= so all subs are in main:: to avoid + * the need for explicit importing. + */ + + /* this must be first: */ + #include "postgres.h" + #include "fmgr.h" + #include "utils/builtins.h" + #include "utils/bytea.h" /* for byteain & byteaout */ + #include "mb/pg_wchar.h" /* for GetDatabaseEncoding */ + /* Defined by Perl */ + #undef _ + + /* perl stuff */ + #include "plperl.h" + + + /* + * Implementation of plperl's elog() function + * + * If the error level is less than ERROR, we'll just emit the message and + * return. When it is ERROR, elog() will longjmp, which we catch and + * turn into a Perl croak(). Note we are assuming that elog() can't have + * any internal failures that are so bad as to require a transaction abort. + * + * This is out-of-line to suppress "might be clobbered by longjmp" warnings. + */ + static void + do_util_elog(int level, char *message) + { + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + elog(level, "%s", message); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak("%s", edata->message); + } + PG_END_TRY(); + } + + static SV * + newSVstring_len(const char *str, STRLEN len) + { + SV *sv; + + sv = newSVpvn(str, len); + #if PERL_BCDVERSION >= 0x5006000L + if (GetDatabaseEncoding() == PG_UTF8) + SvUTF8_on(sv); + #endif + return sv; + } + + static text * + sv2text(SV *sv) + { + STRLEN sv_len; + char *sv_pv; + + if (!sv) + sv = &PL_sv_undef; + sv_pv = SvPV(sv, sv_len); + return cstring_to_text_with_len(sv_pv, sv_len); + } + + MODULE = PostgreSQL::InServer::Util PREFIX = util_ + + PROTOTYPES: ENABLE + VERSIONCHECK: DISABLE + + int + _aliased_constants() + PROTOTYPE: + ALIAS: + DEBUG = DEBUG2 + LOG = LOG + INFO = INFO + NOTICE = NOTICE + WARNING = WARNING + ERROR = ERROR + CODE: + /* uses the ALIAS value as the return value */ + RETVAL = ix; + OUTPUT: + RETVAL + + + void + util_elog(level, message) + int level + char* message + CODE: + if (level > ERROR) /* no PANIC allowed thanks */ + level = ERROR; + if (level < DEBUG5) + level = DEBUG5; + do_util_elog(level, message); + + SV * + util_quote_literal(sv) + SV *sv + CODE: + if (!sv || !SvOK(sv)) { + RETVAL = &PL_sv_undef; + } + else { + text *arg = sv2text(sv); + text *ret = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg))); + RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ)); + } + OUTPUT: + RETVAL + + SV * + util_quote_nullable(sv) + SV *sv + CODE: + if (!sv || !SvOK(sv)) { + RETVAL = newSVstring_len("NULL", 4); + } + else { + text *arg = sv2text(sv); + text *ret = DatumGetTextP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg))); + RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ)); + } + OUTPUT: + RETVAL + + SV * + util_quote_ident(sv) + SV *sv + PREINIT: + text *arg; + text *ret; + CODE: + arg = sv2text(sv); + ret = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg))); + RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ)); + OUTPUT: + RETVAL + + SV * + util_decode_bytea(sv) + SV *sv + PREINIT: + char *arg; + text *ret; + CODE: + arg = SvPV_nolen(sv); + ret = DatumGetTextP(DirectFunctionCall1(byteain, PointerGetDatum(arg))); + /* not newSVstring_len because this is raw bytes not utf8'able */ + RETVAL = newSVpvn(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ)); + OUTPUT: + RETVAL + + SV * + util_encode_bytea(sv) + SV *sv + PREINIT: + text *arg; + char *ret; + CODE: + arg = sv2text(sv); + ret = DatumGetCString(DirectFunctionCall1(byteaout, PointerGetDatum(arg))); + RETVAL = newSVstring_len(ret, strlen(ret)); + OUTPUT: + RETVAL + + SV * + looks_like_number(sv) + SV *sv + CODE: + if (!SvOK(sv) || (SvPOK(sv) && SvCUR(sv)==0)) + RETVAL = &PL_sv_undef; + else if ( looks_like_number(sv) ) + RETVAL = &PL_sv_yes; + else + RETVAL = &PL_sv_no; + OUTPUT: + RETVAL + + + BOOT: + items = 0; /* avoid 'unused variable' warning */ diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out index c1cf7ae..8dd449e 100644 *** a/src/pl/plperl/expected/plperl.out --- b/src/pl/plperl/expected/plperl.out *************** $$ LANGUAGE plperl; *** 563,570 **** NOTICE: This is a test CONTEXT: PL/Perl anonymous code block -- check that restricted operations are rejected in a plperl DO block ! DO $$ use Config; $$ LANGUAGE plperl; ! ERROR: 'require' trapped by operation mask at line 1. CONTEXT: PL/Perl anonymous code block -- -- Test compilation of unicode regex --- 563,581 ---- NOTICE: This is a test CONTEXT: PL/Perl anonymous code block -- check that restricted operations are rejected in a plperl DO block ! DO $$ eval "1+1"; $$ LANGUAGE plperl; ! ERROR: 'eval "string"' trapped by operation mask at line 1. ! CONTEXT: PL/Perl anonymous code block ! -- check that we can't "use" a module that's not been loaded already ! -- compile-time error: "Unable to load blib.pm into plperl" ! DO $$ use blib; $$ LANGUAGE plperl; ! ERROR: Unable to load blib.pm into plperl at line 1. ! BEGIN failed--compilation aborted at line 1. ! CONTEXT: PL/Perl anonymous code block ! -- check that we can "use" a module that has already been loaded ! -- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use ! DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl; ! ERROR: Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1. CONTEXT: PL/Perl anonymous code block -- -- Test compilation of unicode regex diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out index 1791d3c..89497e3 100644 *** a/src/pl/plperl/expected/plperl_elog.out --- b/src/pl/plperl/expected/plperl_elog.out *************** create or replace function perl_warn(tex *** 21,27 **** $$; select perl_warn('implicit elog via warn'); NOTICE: implicit elog via warn at line 4. - CONTEXT: PL/Perl function "perl_warn" perl_warn ----------- --- 21,26 ---- diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out index 72ae1ba..497e688 100644 *** a/src/pl/plperl/expected/plperl_shared.out --- b/src/pl/plperl/expected/plperl_shared.out *************** *** 1,3 **** --- 1,11 ---- + -- test plperl.on_plperl_init via the shared hash + -- (must be done before plperl is initialized) + -- Here we are testing the fact that on_trusted_init gets run, + -- and that it can alter %_SHARED, + -- and that untrusted ops are caught. + -- We use a BEGIN block so the assignment happens before the + -- eval gets noticed and aborts the compilation. + SET plperl.on_trusted_init = ' BEGIN { $_SHARED{on_init} = 42 } eval "will be trapped"'; -- test the shared hash create function setme(key text, val text) returns void language plperl as $$ *************** create function setme(key text, val text *** 6,11 **** --- 14,21 ---- $_SHARED{$key}= $val; $$; + WARNING: Error executing plperl.on_trusted_init: 'eval "string"' trapped by operation mask at line 2. + CONTEXT: compilation of PL/Perl function "setme" create function getme(key text) returns text language plperl as $$ my $key = shift; *************** select getme('ourkey'); *** 24,26 **** --- 34,42 ---- ourval (1 row) + select getme('on_init'); + getme + ------- + 42 + (1 row) + diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out index ...6ad071d . *** a/src/pl/plperl/expected/plperl_util.out --- b/src/pl/plperl/expected/plperl_util.out *************** *** 0 **** --- 1,167 ---- + -- test plperl utility functions (defined in Util.xs) + -- test quote_literal + create or replace function perl_quote_literal() returns setof text language plperl as $$ + return_next "undef: ".quote_literal(undef); + return_next sprintf"$_: ".quote_literal($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; + $$; + select perl_quote_literal(); + perl_quote_literal + -------------------- + undef: + foo: 'foo' + a'b: 'a''b' + a"b: 'a"b' + c''d: 'c''''d' + e\f: E'e\\f' + : '' + (7 rows) + + -- test quote_nullable + create or replace function perl_quote_nullable() returns setof text language plperl as $$ + return_next "undef: ".quote_nullable(undef); + return_next sprintf"$_: ".quote_nullable($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; + $$; + select perl_quote_nullable(); + perl_quote_nullable + --------------------- + undef: NULL + foo: 'foo' + a'b: 'a''b' + a"b: 'a"b' + c''d: 'c''''d' + e\f: E'e\\f' + : '' + (7 rows) + + -- test quote_ident + create or replace function perl_quote_ident() returns setof text language plperl as $$ + return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled + return_next "$_: ".quote_ident($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{}; + return undef; + $$; + select perl_quote_ident(); + perl_quote_ident + ------------------ + undef: "" + foo: foo + a'b: "a'b" + a"b: "a""b" + c''d: "c''d" + e\f: "e\f" + g.h: "g.h" + : "" + (8 rows) + + -- test decode_bytea + create or replace function perl_decode_bytea() returns setof text language plperl as $$ + return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled + return_next "$_: ".decode_bytea($_) + for q{foo}, q{a\047b}, q{}; + return undef; + $$; + select perl_decode_bytea(); + perl_decode_bytea + ------------------- + undef: + foo: foo + a\047b: a'b + : + (4 rows) + + -- test encode_bytea + create or replace function perl_encode_bytea() returns setof text language plperl as $$ + return_next encode_bytea(undef); # generates undef warning if warnings enabled + return_next encode_bytea($_) + for q{@}, qq{@\x01@}, qq{@\x00@}, q{}; + return undef; + $$; + select perl_encode_bytea(); + perl_encode_bytea + ------------------- + \x + \x40 + \x400140 + \x400040 + \x + (5 rows) + + -- test encode_array_literal + create or replace function perl_encode_array_literal() returns setof text language plperl as $$ + return_next encode_array_literal(undef); + return_next encode_array_literal(0); + return_next encode_array_literal(42); + return_next encode_array_literal($_) + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return_next encode_array_literal($_,'|') + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return undef; + $$; + select perl_encode_array_literal(); + perl_encode_array_literal + --------------------------- + + 0 + 42 + {} + {"0"} + {"1", "2", "3", "4", "5"} + {{}} + {{"1", "2", {"3"}}, "4"} + {} + {"0"} + {"1"|"2"|"3"|"4"|"5"} + {{}} + {{"1"|"2"|{"3"}}|"4"} + (13 rows) + + -- test encode_array_constructor + create or replace function perl_encode_array_constructor() returns setof text language plperl as $$ + return_next encode_array_constructor(undef); + return_next encode_array_constructor(0); + return_next encode_array_constructor(42); + return_next encode_array_constructor($_) + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return undef; + $$; + select perl_encode_array_constructor(); + perl_encode_array_constructor + ----------------------------------------- + NULL + '0' + '42' + ARRAY[] + ARRAY['0'] + ARRAY['1', '2', '3', '4', '5'] + ARRAY[ARRAY[]] + ARRAY[ARRAY['1', '2', ARRAY['3']], '4'] + (8 rows) + + -- test looks_like_number + create or replace function perl_looks_like_number() returns setof text language plperl as $$ + return_next "undef is undef" if not defined looks_like_number(undef); + return_next "$_: ". (looks_like_number($_) ? "number" : "not number") + for 'foo', 0, 1, 1.3, '+3.e-4', + '42 x', # trailing garbage + '99 ', # trailing space + ' 99'; # leading space + return undef; + $$; + select perl_looks_like_number(); + perl_looks_like_number + ------------------------ + undef is undef + foo: not number + 0: number + 1: number + 1.3: number + +3.e-4: number + 42 x: not number + 99 : number + 99: number + (9 rows) + diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl index d2d5518..a62b6b7 100644 *** a/src/pl/plperl/plc_perlboot.pl --- b/src/pl/plperl/plc_perlboot.pl *************** *** 1,8 **** ! SPI::bootstrap(); use vars qw(%_SHARED); sub ::plperl_warn { (my $msg = shift) =~ s/\(eval \d+\) //g; &elog(&NOTICE, $msg); } $SIG{__WARN__} = \&::plperl_warn; --- 1,12 ---- ! BEGIN { PostgreSQL::InServer::Util::bootstrap() } ! ! use strict; ! use warnings; use vars qw(%_SHARED); sub ::plperl_warn { (my $msg = shift) =~ s/\(eval \d+\) //g; + chomp $msg; &elog(&NOTICE, $msg); } $SIG{__WARN__} = \&::plperl_warn; *************** sub ::plperl_die { *** 13,50 **** } $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}); } --- 17,79 ---- } $SIG{__DIE__} = \&::plperl_die; + sub ::mkfuncsrc { + my ($name, $imports, $prolog, $src) = @_; + + my $BEGIN = join "\n", map { + my $names = $imports->{$_} || []; + "$_->import(qw(@$names));" + } keys %$imports; + $BEGIN &&= "BEGIN { $BEGIN }"; + + $name =~ s/\\/\\\\/g; + $name =~ s/::|'/_/g; # avoid package delimiters + + my $funcsrc; + $funcsrc .= qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ]; + #warn "plperl mkfuncsrc: $funcsrc\n"; + return $funcsrc; + } + + # see also mksafefunc() in plc_safe_ok.pl sub ::mkunsafefunc { ! no strict; # default to no strict for the eval ! my $ret = eval(::mkfuncsrc(@_)); $@ =~ s/\(eval \d+\) //g if $@; return $ret; } ! sub ::encode_array_literal { ! my ($arg, $delim) = @_; ! return $arg ! if ref $arg ne 'ARRAY'; ! $delim = ', ' unless defined $delim; ! my $res = ''; ! foreach my $elem (@$arg) { ! $res .= $delim if length $res; ! if (ref $elem) { ! $res .= ::encode_array_literal($elem, $delim); ! } ! elsif (defined $elem) { ! (my $str = $elem) =~ s/(["\\])/\\$1/g; ! $res .= qq("$str"); ! } ! else { ! $res .= 'NULL'; ! } ! } ! return qq({$res}); } ! sub ::encode_array_constructor { ! my $arg = shift; ! return quote_nullable($arg) ! if ref $arg ne 'ARRAY'; ! my $res = join ", ", map { ! (ref $_) ! ? ::encode_array_constructor($_) ! : ::quote_nullable($_) ! } @$arg; ! return "ARRAY[$res]"; } + diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl index 838ccc6..da47341 100644 *** a/src/pl/plperl/plc_safe_bad.pl --- b/src/pl/plperl/plc_safe_bad.pl *************** *** 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') }]); } - --- 1,13 ---- ! # Minimal version of plc_safe_ok.pl ! # Executed if Safe is too old or doesn't load for any reason my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later'; ! sub mksafefunc { ! my ($name, $pragma, $prolog, $src) = @_; ! # replace $src with code to generate an error ! $src = qq{ ::elog(::ERROR,"$msg\n") }; ! my $ret = eval(::mkfuncsrc($name, $pragma, '', $src)); ! $@ =~ s/\(eval \d+\) //g if $@; ! return $ret; } diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl index 73c5573..f56463c 100644 *** a/src/pl/plperl/plc_safe_ok.pl --- b/src/pl/plperl/plc_safe_ok.pl *************** *** 1,13 **** 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 ]); --- 1,17 ---- + use strict; + use warnings; use vars qw($PLContainer); $PLContainer = new Safe('PLPerl'); $PLContainer->permit_only(':default'); ! $PLContainer->permit(qw[:base_math !:base_io sort time require]); $PLContainer->share(qw[&elog &return_next + "e_literal "e_nullable "e_ident &encode_bytea &decode_bytea + &looks_like_number &spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query &spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan ! &encode_array_literal &encode_array_constructor &DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]); *************** $PLContainer->share(qw[&elog &return_nex *** 16,33 **** # 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; } --- 20,36 ---- # 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[caller]); ! $PLContainer->reval('require strict;') or die $@; ! $PLContainer->deny(qw[caller]); ! # called directly for plperl.on_trusted_init ! sub ::safe_eval { ! my $ret = $PLContainer->reval(shift); $@ =~ s/\(eval \d+\) //g if $@; return $ret; } ! sub ::mksafefunc { ! return ::safe_eval(::mkfuncsrc(@_)); } diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c index f919f04..1a29a3a 100644 *** a/src/pl/plperl/plperl.c --- b/src/pl/plperl/plperl.c *************** static HTAB *plperl_proc_hash = NULL; *** 137,142 **** --- 137,145 ---- static HTAB *plperl_query_hash = NULL; static bool plperl_use_strict = false; + static char *plperl_on_perl_init = NULL; + static char *plperl_on_trusted_init = NULL; + static char *plperl_on_untrusted_init = NULL; /* this is saved and restored by plperl_call_handler */ static plperl_call_data *current_call_data = NULL; *************** Datum plperl_inline_handler(PG_FUNCTION *** 149,155 **** 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); --- 152,160 ---- Datum plperl_validator(PG_FUNCTION_ARGS); void _PG_init(void); ! static PerlInterpreter *plperl_create_interp(void); ! static void plperl_destroy_interp(PerlInterpreter **); ! static void plperl_fini(void); static Datum plperl_func_handler(PG_FUNCTION_ARGS); static Datum plperl_trigger_handler(PG_FUNCTION_ARGS); *************** static plperl_proc_desc *compile_plperl_ *** 159,173 **** 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); static void plperl_inline_callback(void *arg); /* * This routine is a crock, and so is everyplace that calls it. The problem --- 164,180 ---- static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc); static void plperl_init_shared_libs(pTHX); static void plperl_safe_init(void); + static SV *plperl_eval_pv(const char *src, int level, const char *errfmt); 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, Oid fn_oid); 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); static void plperl_inline_callback(void *arg); + static char *strip_trailing_ws(const char *msg); /* * This routine is a crock, and so is everyplace that calls it. The problem *************** _PG_init(void) *** 212,217 **** --- 219,248 ---- PGC_USERSET, 0, NULL, NULL); + DefineCustomStringVariable("plperl.on_perl_init", + gettext_noop("Perl code to execute when interpreter is initialized."), + NULL, + &plperl_on_perl_init, + NULL, + PGC_SUSET, 0, + NULL, NULL); + + DefineCustomStringVariable("plperl.on_trusted_init", + gettext_noop("Perl code to execute when plperl is initialized for user."), + NULL, + &plperl_on_trusted_init, + NULL, + PGC_USERSET, 0, + NULL, NULL); + + DefineCustomStringVariable("plperl.on_untrusted_init", + gettext_noop("Perl code to execute when plperlu is initialized for user."), + NULL, + &plperl_on_untrusted_init, + NULL, + PGC_USERSET, 0, + NULL, NULL); + EmitWarningsOnPlaceholders("plperl"); MemSet(&hash_ctl, 0, sizeof(hash_ctl)); *************** _PG_init(void) *** 230,241 **** &hash_ctl, HASH_ELEM); ! plperl_held_interp = plperl_init_interp(); interp_state = INTERP_HELD; inited = true; } #define SAFE_MODULE \ "require Safe; $Safe::VERSION" --- 261,288 ---- &hash_ctl, HASH_ELEM); ! plperl_held_interp = plperl_create_interp(); interp_state = INTERP_HELD; + atexit(plperl_fini); + inited = true; } + + /* + * Cleanup perl interpreters, including running END blocks. + * Does not fully undo the actions of _PG_init() nor make it callable again. + */ + static void + plperl_fini(void) + { + plperl_destroy_interp(&plperl_trusted_interp); + plperl_destroy_interp(&plperl_untrusted_interp); + plperl_destroy_interp(&plperl_held_interp); + } + + #define SAFE_MODULE \ "require Safe; $Safe::VERSION" *************** _PG_init(void) *** 246,259 **** * assign that interpreter if it is available to either the trusted or * untrusted interpreter. If it has already been assigned, and we need to * create the other interpreter, we do that if we can, or error out. - * We detect if it is safe to run two interpreters during the setup of the - * dummy interpreter. */ static void check_interp(bool trusted) { if (interp_state == INTERP_HELD) { if (trusted) --- 293,327 ---- * assign that interpreter if it is available to either the trusted or * untrusted interpreter. If it has already been assigned, and we need to * create the other interpreter, we do that if we can, or error out. */ static void check_interp(bool trusted) { + EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv); + + /* + * handle simple cases + */ + if (interp_state == INTERP_BOTH || + ( trusted && interp_state == INTERP_TRUSTED) || + (!trusted && interp_state == INTERP_UNTRUSTED)) + { + if (trusted_context != trusted) + { + if (trusted) + PERL_SET_CONTEXT(plperl_trusted_interp); + else + PERL_SET_CONTEXT(plperl_untrusted_interp); + trusted_context = trusted; + } + return; + } + + /* + * adopt held interp if free, else create new one if possible + */ if (interp_state == INTERP_HELD) { if (trusted) *************** check_interp(bool trusted) *** 266,307 **** plperl_untrusted_interp = plperl_held_interp; interp_state = INTERP_UNTRUSTED; } - 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) || - (!trusted && interp_state == INTERP_UNTRUSTED)) - { - if (trusted_context != trusted) - { - if (trusted) - PERL_SET_CONTEXT(plperl_trusted_interp); - else - PERL_SET_CONTEXT(plperl_untrusted_interp); - 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 } } /* --- 334,381 ---- plperl_untrusted_interp = plperl_held_interp; interp_state = INTERP_UNTRUSTED; } } else { #ifdef MULTIPLICITY ! PerlInterpreter *plperl = plperl_create_interp(); if (trusted) plperl_trusted_interp = plperl; else plperl_untrusted_interp = plperl; interp_state = INTERP_BOTH; #else elog(ERROR, "cannot allocate second Perl interpreter on this platform"); #endif } + plperl_held_interp = NULL; + trusted_context = trusted; + + /* + * initialization - done after plperl_*_interp and trusted_context + * updates above to ensure a clean state (and thereby avoid recursion via + * plperl_safe_init) + */ + if (trusted) + plperl_safe_init(); + else + { + if (plperl_on_untrusted_init && *plperl_on_untrusted_init) + { + plperl_eval_pv(plperl_on_untrusted_init, WARNING, + "Error executing plperl.on_untrusted_init: %s"); + } + } + + /* + * enable access to the database + */ + newXS("PostgreSQL::InServer::SPI::bootstrap", + boot_PostgreSQL__InServer__SPI, __FILE__); + plperl_eval_pv("PostgreSQL::InServer::SPI::bootstrap()", ERROR, + "Error executing PostgreSQL::InServer::SPI::bootstrap: %s"); + } /* *************** restore_context(bool old_context) *** 321,336 **** } static PerlInterpreter * ! plperl_init_interp(void) { PerlInterpreter *plperl; static int perl_sys_init_done; ! static char *embedding[3] = { "", "-e", PLC_PERLBOOT }; int nargs = 3; #ifdef WIN32 /* --- 395,420 ---- } static PerlInterpreter * ! plperl_create_interp(void) { PerlInterpreter *plperl; static int perl_sys_init_done; ! /* ! * The perl interpreter configuration can be altered via the environment variables ! * like PERL5LIB, PERL5OPT, PERL_UNICODE etc., documented in the perlrun documentation. ! */ ! static char *embedding[3+2] = { "", "-e", PLC_PERLBOOT }; int nargs = 3; + if (plperl_on_perl_init) + { + embedding[nargs++] = "-e"; + embedding[nargs++] = plperl_on_perl_init; + } + #ifdef WIN32 /* *************** plperl_init_interp(void) *** 399,407 **** PERL_SET_CONTEXT(plperl); perl_construct(plperl); ! perl_parse(plperl, plperl_init_shared_libs, ! nargs, embedding, NULL); ! perl_run(plperl); #ifdef WIN32 --- 483,496 ---- PERL_SET_CONTEXT(plperl); perl_construct(plperl); ! PL_exit_flags |= PERL_EXIT_DESTRUCT_END; ! ! if (perl_parse(plperl, plperl_init_shared_libs, ! nargs, embedding, NULL) != 0) ! elog(ERROR, "Error parsing perl initialization"); ! ! if (perl_run(plperl) != 0) ! elog(ERROR, "Error running perl initialization"); #ifdef WIN32 *************** plperl_init_interp(void) *** 449,459 **** static void plperl_safe_init(void) { SV *safe_version_sv; ! safe_version_sv = eval_pv(SAFE_MODULE, FALSE); /* TRUE = croak if failure */ /* * We actually want to reject Safe version < 2.09, but it's risky to --- 538,588 ---- static void + plperl_destroy_interp(PerlInterpreter **interp) + { + if (interp && *interp) + { + perl_destruct(*interp); + perl_free(*interp); + *interp = NULL; + } + } + + + /* + * Our safe implementation of the require opcode. + * This is safe because it's completely unable to load any code. + * If the requested file/module has already been loaded it'll return true. + * If not, it'll die. + * So now "use Foo;" will work if Foo has already been loaded. + */ + static OP * + pp_safe_require(pTHX) + { + dVAR; dSP; + SV *sv, **svp; + char *name; + STRLEN len; + + sv = POPs; + name = SvPV(sv, len); + if (!(name && len > 0 && *name)) + RETPUSHNO; + + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp && *svp != &PL_sv_undef) + RETPUSHYES; + + DIE(aTHX_ "Unable to load %s into plperl", name); + } + + + static void plperl_safe_init(void) { SV *safe_version_sv; ! safe_version_sv = plperl_eval_pv(SAFE_MODULE, WARNING, "%s"); /* * We actually want to reject Safe version < 2.09, but it's risky to *************** plperl_safe_init(void) *** 463,473 **** if (SvNV(safe_version_sv) < 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) { /* --- 592,603 ---- if (SvNV(safe_version_sv) < 2.0899) { /* not safe, so disallow all trusted funcs */ ! plperl_eval_pv(PLC_SAFE_BAD, ERROR, "Error initializing stub plperl: %s"); } else { ! plperl_eval_pv(PLC_SAFE_OK, ERROR, "Error initializing plperl: %s"); ! if (GetDatabaseEncoding() == PG_UTF8) { /* *************** plperl_safe_init(void) *** 479,484 **** --- 609,615 ---- */ plperl_proc_desc desc; FunctionCallInfoData fcinfo; + SV *perlret; desc.proname = "utf8fix"; desc.lanpltrusted = true; *************** plperl_safe_init(void) *** 488,503 **** /* 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); } } } /* --- 619,675 ---- /* compile the function */ plperl_create_sub(&desc, ! "return shift =~ /\\xa9/i ? 'true' : 'false' ;", 0); /* 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 */ ! perlret = plperl_call_perl_func(&desc, &fcinfo); ! ! SvREFCNT_dec(perlret); ! } ! ! if (plperl_on_trusted_init && *plperl_on_trusted_init) ! { ! dSP; ! ! PUSHMARK(SP); ! XPUSHs(sv_2mortal(newSVstring(plperl_on_trusted_init))); ! PUTBACK; ! ! call_pv("::safe_eval", G_VOID); ! SPAGAIN; ! ! if (SvTRUE(ERRSV)) ! { ! elog(WARNING, "Error executing plperl.on_trusted_init: %s", ! strip_trailing_ws(SvPV_nolen(ERRSV))); ! } } } + + /* now we've finished initializing and loading the modules we need, + * redirect the require opcode to our safe version. + */ + PL_ppaddr[OP_REQUIRE] = pp_safe_require; + } + + /* + * wrapper for eval_pv that calls elog on error + */ + static SV * + plperl_eval_pv(const char *src, int level, const char *errfmt) + { + SV *sv; + + sv = eval_pv(src, (errfmt) ? FALSE : TRUE); /* croak if error and errfmt is NULL */ + if (SvTRUE(ERRSV)) + { + elog(level, errfmt, strip_trailing_ws(SvPV_nolen(ERRSV))); + } + return sv; } /* *************** plperl_convert_to_pg_array(SV *src) *** 557,575 **** { SV *rv; int count; - dSP; PUSHMARK(SP); XPUSHs(src); PUTBACK; ! count = call_pv("::_plperl_to_pg_array", G_SCALAR); SPAGAIN; if (count != 1) ! elog(ERROR, "unexpected _plperl_to_pg_array failure"); rv = POPs; --- 729,746 ---- { SV *rv; int count; dSP; PUSHMARK(SP); XPUSHs(src); PUTBACK; ! count = call_pv("::encode_array_literal", G_SCALAR); SPAGAIN; if (count != 1) ! elog(ERROR, "unexpected encode_array_literal failure"); rv = POPs; *************** plperl_trigger_build_args(FunctionCallIn *** 594,599 **** --- 765,771 ---- HV *hv; hv = newHV(); + hv_ksplit(hv, 12); /* pre-grow the hash */ tdata = (TriggerData *) fcinfo->context; tupdesc = tdata->tg_relation->rd_att; *************** plperl_trigger_build_args(FunctionCallIn *** 648,653 **** --- 820,826 ---- { AV *av = newAV(); + av_extend(av, tdata->tg_trigger->tgnargs); for (i = 0; i < tdata->tg_trigger->tgnargs; i++) av_push(av, newSVstring(tdata->tg_trigger->tgargs[i])); hv_store_string(hv, "args", newRV_noinc((SV *) av)); *************** plperl_inline_handler(PG_FUNCTION_ARGS) *** 870,876 **** check_interp(desc.lanpltrusted); ! plperl_create_sub(&desc, codeblock->source_text); if (!desc.reference) /* can this happen? */ elog(ERROR, "could not create internal procedure for anonymous code block"); --- 1043,1049 ---- check_interp(desc.lanpltrusted); ! plperl_create_sub(&desc, codeblock->source_text, 0); if (!desc.reference) /* can this happen? */ elog(ERROR, "could not create internal procedure for anonymous code block"); *************** plperl_validator(PG_FUNCTION_ARGS) *** 975,997 **** /* ! * 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); ! XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;"))); ! XPUSHs(sv_2mortal(newSVstring(s))); PUTBACK; /* --- 1148,1180 ---- /* ! * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is ! * supplied in s, and returns a reference to it */ static void ! plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid) { dSP; bool trusted = prodesc->lanpltrusted; ! char subname[NAMEDATALEN+40]; ! HV *pragma_hv = newHV(); ! SV *subref = NULL; ! int count; ! char *compile_sub; ! ! sprintf(subname, "%s__%u", prodesc->proname, fn_oid); ! ! if (plperl_use_strict) ! hv_store_string(pragma_hv, "strict", (SV*)newAV()); ENTER; SAVETMPS; PUSHMARK(SP); ! EXTEND(SP,4); ! PUSHs(sv_2mortal(newSVstring(subname))); ! PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv))); ! PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;"))); ! PUSHs(sv_2mortal(newSVstring(s))); PUTBACK; /* *************** plperl_create_sub(plperl_proc_desc *prod *** 999,1055 **** * errors properly. Perhaps it's because there's another level of eval * inside mksafefunc? */ ! ! if (trusted && plperl_use_strict) ! compile_sub = "::mk_strict_safefunc"; ! else if (plperl_use_strict) ! compile_sub = "::mk_strict_unsafefunc"; ! else if (trusted) ! compile_sub = "::mksafefunc"; ! else ! compile_sub = "::mkunsafefunc"; ! count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; ! if (count != 1) ! { ! PUTBACK; ! FREETMPS; ! LEAVE; ! elog(ERROR, "didn't get a return item from mksafefunc"); } ! subref = POPs; if (SvTRUE(ERRSV)) { - PUTBACK; - FREETMPS; - LEAVE; ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))))); } ! 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; } --- 1182,1217 ---- * errors properly. Perhaps it's because there's another level of eval * inside mksafefunc? */ ! compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc"; count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; ! if (count == 1) { ! GV *sub_glob = (GV*)POPs; ! if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV) ! subref = newRV_inc((SV*)GvCVu((GV*)sub_glob)); } ! PUTBACK; ! FREETMPS; ! LEAVE; if (SvTRUE(ERRSV)) { ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))))); } ! if (!subref) { ! ereport(ERROR, ! (errcode(ERRCODE_INTERNAL_ERROR), ! errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub))); } prodesc->reference = newSVsv(subref); return; } *************** plperl_create_sub(plperl_proc_desc *prod *** 1063,1078 **** * **********************************************************************/ - EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); - EXTERN_C void boot_SPI(pTHX_ CV *cv); - static void plperl_init_shared_libs(pTHX) { char *file = __FILE__; newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); ! newXS("SPI::bootstrap", boot_SPI, file); } --- 1225,1240 ---- * **********************************************************************/ static void plperl_init_shared_libs(pTHX) { char *file = __FILE__; + EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); + EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv); newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); ! newXS("PostgreSQL::InServer::Util::bootstrap", ! boot_PostgreSQL__InServer__Util, file); } *************** plperl_call_perl_func(plperl_proc_desc * *** 1089,1101 **** SAVETMPS; PUSHMARK(SP); ! XPUSHs(&PL_sv_undef); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { if (fcinfo->argnull[i]) ! XPUSHs(&PL_sv_undef); else if (desc->arg_is_rowtype[i]) { HeapTupleHeader td; --- 1251,1264 ---- SAVETMPS; PUSHMARK(SP); + EXTEND(sp, 1 + desc->nargs); ! PUSHs(&PL_sv_undef); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { if (fcinfo->argnull[i]) ! PUSHs(&PL_sv_undef); else if (desc->arg_is_rowtype[i]) { HeapTupleHeader td; *************** plperl_call_perl_func(plperl_proc_desc * *** 1115,1121 **** tmptup.t_data = td; hashref = plperl_hash_from_tuple(&tmptup, tupdesc); ! XPUSHs(sv_2mortal(hashref)); ReleaseTupleDesc(tupdesc); } else --- 1278,1284 ---- tmptup.t_data = td; hashref = plperl_hash_from_tuple(&tmptup, tupdesc); ! PUSHs(sv_2mortal(hashref)); ReleaseTupleDesc(tupdesc); } else *************** plperl_call_perl_func(plperl_proc_desc * *** 1125,1138 **** tmp = OutputFunctionCall(&(desc->arg_out_func[i]), fcinfo->arg[i]); sv = newSVstring(tmp); ! XPUSHs(sv_2mortal(sv)); pfree(tmp); } } PUTBACK; /* Do NOT use G_KEEPERR here */ ! count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; --- 1288,1301 ---- tmp = OutputFunctionCall(&(desc->arg_out_func[i]), fcinfo->arg[i]); sv = newSVstring(tmp); ! PUSHs(sv_2mortal(sv)); pfree(tmp); } } PUTBACK; /* Do NOT use G_KEEPERR here */ ! count = call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; *************** plperl_call_perl_trigger_func(plperl_pro *** 1188,1194 **** PUTBACK; /* Do NOT use G_KEEPERR here */ ! count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; --- 1351,1357 ---- PUTBACK; /* Do NOT use G_KEEPERR here */ ! count = call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; *************** compile_plperl_function(Oid fn_oid, bool *** 1732,1738 **** check_interp(prodesc->lanpltrusted); ! plperl_create_sub(prodesc, proc_source); restore_context(oldcontext); --- 1895,1901 ---- check_interp(prodesc->lanpltrusted); ! plperl_create_sub(prodesc, proc_source, fn_oid); restore_context(oldcontext); *************** plperl_hash_from_tuple(HeapTuple tuple, *** 1768,1773 **** --- 1931,1937 ---- int i; hv = newHV(); + hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */ for (i = 0; i < tupdesc->natts; i++) { *************** plperl_spi_execute_fetch_result(SPITuple *** 1895,1900 **** --- 2059,2065 ---- int i; rows = newAV(); + av_extend(rows, processed); for (i = 0; i < processed; i++) { row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc); diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h index c6eb505..0cdcade 100644 *** a/src/pl/plperl/plperl.h --- b/src/pl/plperl/plperl.h *************** *** 30,57 **** #include "EXTERN.h" #include "perl.h" #include "XSUB.h" - #include "ppport.h" ! /* just in case these symbols aren't provided */ ! #ifndef pTHX_ ! #define pTHX_ ! #define pTHX void ! #endif /* perl may have a different width of "bool", don't buy it */ #ifdef bool #undef bool #endif ! /* routines from spi_internal.c */ ! int spi_DEBUG(void); ! int spi_LOG(void); ! int spi_INFO(void); ! int spi_NOTICE(void); ! int spi_WARNING(void); ! int spi_ERROR(void); ! ! /* routines from plperl.c */ HV *plperl_spi_exec(char *, int); void plperl_return_next(SV *); SV *plperl_spi_query(char *); --- 30,48 ---- #include "EXTERN.h" #include "perl.h" #include "XSUB.h" ! /* perl version and platform portability */ ! #define NEED_eval_pv ! #define NEED_newRV_noinc ! #define NEED_sv_2pv_flags ! #include "ppport.h" /* perl may have a different width of "bool", don't buy it */ #ifdef bool #undef bool #endif ! /* declare routines from plperl.c for access by .xs files */ HV *plperl_spi_exec(char *, int); void plperl_return_next(SV *); SV *plperl_spi_query(char *); diff --git a/src/pl/plperl/spi_internal.c b/src/pl/plperl/spi_internal.c index 1bb82b0..e69de29 100644 *** a/src/pl/plperl/spi_internal.c --- b/src/pl/plperl/spi_internal.c *************** *** 1,51 **** - /* - * $PostgreSQL$ - * - * - * This kludge is necessary because of the conflicting - * definitions of 'DEBUG' between postgres and perl. - * we'll live. - */ - - #include "postgres.h" - /* Defined by Perl */ - #undef _ - - /* perl stuff */ - #include "plperl.h" - - int - spi_DEBUG(void) - { - return DEBUG2; - } - - int - spi_LOG(void) - { - return LOG; - } - - int - spi_INFO(void) - { - return INFO; - } - - int - spi_NOTICE(void) - { - return NOTICE; - } - - int - spi_WARNING(void) - { - return WARNING; - } - - int - spi_ERROR(void) - { - return ERROR; - } --- 0 ---- diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql index bf335fe..e0e6667 100644 *** a/src/pl/plperl/sql/plperl.sql --- b/src/pl/plperl/sql/plperl.sql *************** DO $$ *** 368,374 **** $$ LANGUAGE plperl; -- check that restricted operations are rejected in a plperl DO block ! DO $$ use Config; $$ LANGUAGE plperl; -- -- Test compilation of unicode regex --- 368,382 ---- $$ LANGUAGE plperl; -- check that restricted operations are rejected in a plperl DO block ! DO $$ eval "1+1"; $$ LANGUAGE plperl; ! ! -- check that we can't "use" a module that's not been loaded already ! -- compile-time error: "Unable to load blib.pm into plperl" ! DO $$ use blib; $$ LANGUAGE plperl; ! ! -- check that we can "use" a module that has already been loaded ! -- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use ! DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl; -- -- Test compilation of unicode regex diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql index 3e99e59..121d0ee 100644 *** a/src/pl/plperl/sql/plperl_shared.sql --- b/src/pl/plperl/sql/plperl_shared.sql *************** *** 1,3 **** --- 1,13 ---- + -- test plperl.on_plperl_init via the shared hash + -- (must be done before plperl is initialized) + + -- Here we are testing the fact that on_trusted_init gets run, + -- and that it can alter %_SHARED, + -- and that untrusted ops are caught. + -- We use a BEGIN block so the assignment happens before the + -- eval gets noticed and aborts the compilation. + SET plperl.on_trusted_init = ' BEGIN { $_SHARED{on_init} = 42 } eval "will be trapped"'; + -- test the shared hash create function setme(key text, val text) returns void language plperl as $$ *************** select setme('ourkey','ourval'); *** 19,22 **** select getme('ourkey'); ! --- 29,32 ---- select getme('ourkey'); ! select getme('on_init'); diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql index ...df01de2 . *** a/src/pl/plperl/sql/plperl_util.sql --- b/src/pl/plperl/sql/plperl_util.sql *************** *** 0 **** --- 1,98 ---- + -- test plperl utility functions (defined in Util.xs) + + -- test quote_literal + + create or replace function perl_quote_literal() returns setof text language plperl as $$ + return_next "undef: ".quote_literal(undef); + return_next sprintf"$_: ".quote_literal($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; + $$; + + select perl_quote_literal(); + + -- test quote_nullable + + create or replace function perl_quote_nullable() returns setof text language plperl as $$ + return_next "undef: ".quote_nullable(undef); + return_next sprintf"$_: ".quote_nullable($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; + $$; + + select perl_quote_nullable(); + + -- test quote_ident + + create or replace function perl_quote_ident() returns setof text language plperl as $$ + return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled + return_next "$_: ".quote_ident($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{}; + return undef; + $$; + + select perl_quote_ident(); + + -- test decode_bytea + + create or replace function perl_decode_bytea() returns setof text language plperl as $$ + return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled + return_next "$_: ".decode_bytea($_) + for q{foo}, q{a\047b}, q{}; + return undef; + $$; + + select perl_decode_bytea(); + + -- test encode_bytea + + create or replace function perl_encode_bytea() returns setof text language plperl as $$ + return_next encode_bytea(undef); # generates undef warning if warnings enabled + return_next encode_bytea($_) + for q{@}, qq{@\x01@}, qq{@\x00@}, q{}; + return undef; + $$; + + select perl_encode_bytea(); + + -- test encode_array_literal + + create or replace function perl_encode_array_literal() returns setof text language plperl as $$ + return_next encode_array_literal(undef); + return_next encode_array_literal(0); + return_next encode_array_literal(42); + return_next encode_array_literal($_) + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return_next encode_array_literal($_,'|') + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return undef; + $$; + + select perl_encode_array_literal(); + + -- test encode_array_constructor + + create or replace function perl_encode_array_constructor() returns setof text language plperl as $$ + return_next encode_array_constructor(undef); + return_next encode_array_constructor(0); + return_next encode_array_constructor(42); + return_next encode_array_constructor($_) + for [], [0], [1..5], [[]], [[1,2,[3]],4]; + return undef; + $$; + + select perl_encode_array_constructor(); + + -- test looks_like_number + + create or replace function perl_looks_like_number() returns setof text language plperl as $$ + return_next "undef is undef" if not defined looks_like_number(undef); + return_next "$_: ". (looks_like_number($_) ? "number" : "not number") + for 'foo', 0, 1, 1.3, '+3.e-4', + '42 x', # trailing garbage + '99 ', # trailing space + ' 99'; # leading space + return undef; + $$; + + select perl_looks_like_number();