diff options
Diffstat (limited to 'src/pl/plperl')
63 files changed, 20210 insertions, 0 deletions
diff --git a/src/pl/plperl/.gitignore b/src/pl/plperl/.gitignore new file mode 100644 index 0000000..1a79873 --- /dev/null +++ b/src/pl/plperl/.gitignore @@ -0,0 +1,9 @@ +/SPI.c +/Util.c +/perlchunks.h +/plperl_opmask.h + +# Generated subdirectories +/log/ +/results/ +/tmp_check/ diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile new file mode 100644 index 0000000..919d464 --- /dev/null +++ b/src/pl/plperl/GNUmakefile @@ -0,0 +1,130 @@ +# Makefile for PL/Perl +# src/pl/plperl/GNUmakefile + +subdir = src/pl/plperl +top_builddir = ../../.. +include $(top_builddir)/src/Makefile.global + +ifeq ($(PORTNAME), win32) +override CPPFLAGS += -DPLPERL_HAVE_UID_GID +# Perl on win32 contains /* within comment all over the header file, +# so disable this warning. +override CPPFLAGS += -Wno-comment +endif + +# Note: we need to include the perl_includespec directory last, +# probably because it sometimes contains some header files with names +# that clash with some of ours, or with some that we include, notably on +# Windows. +override CPPFLAGS := -I. -I$(srcdir) $(CPPFLAGS) $(perl_embed_ccflags) $(perl_includespec) + +# this is often, but not always, the same directory named by perl_includespec +rpathdir = $(perl_archlibexp)/CORE + +PGFILEDESC = "PL/Perl - procedural language" + +NAME = plperl + +OBJS = plperl.o SPI.o Util.o $(WIN32RES) + +DATA = plperl.control plperl--1.0.sql \ + plperlu.control plperlu--1.0.sql + +PERLCHUNKS = plc_perlboot.pl plc_trusted.pl + +# Perl on win32 ships with import libraries only for Microsoft Visual C++, +# which are not compatible with mingw gcc. Therefore we need to build a +# new import library to link with. +ifeq ($(PORTNAME), win32) + +perlwithver := $(subst -l,,$(filter -l%, $(perl_embed_ldflags))) +PERLDLL := $(dir $(subst ',,$(PERL)))$(perlwithver).dll +# we no longer want to include the original -l spec in SHLIB_LINK +override perl_embed_ldflags := + +OBJS += lib$(perlwithver).a + +lib$(perlwithver).a: $(perlwithver).def + dlltool --dllname $(perlwithver).dll --def $(perlwithver).def --output-lib lib$(perlwithver).a + +$(perlwithver).def: $(PERLDLL) + pexports $^ > $@ + +endif # win32 + + +SHLIB_LINK = $(perl_embed_ldflags) + +REGRESS_OPTS = --dbname=$(PL_TESTDB) +REGRESS = plperl_setup plperl plperl_lc plperl_trigger plperl_shared \ + plperl_elog plperl_util plperl_init plperlu plperl_array \ + plperl_call plperl_transaction +# if Perl can support two interpreters in one backend, +# test plperl-and-plperlu cases +ifneq ($(PERL),) +ifeq ($(shell $(PERL) -V:usemultiplicity), usemultiplicity='define';) + REGRESS += plperl_plperlu +endif +endif + +# where to find xsubpp for building XS. +XSUBPPDIR = $(shell $(PERL) -e 'use List::Util qw(first); print first { -r "$$_/ExtUtils/xsubpp" } @INC') + +include $(top_srcdir)/src/Makefile.shlib + +plperl.o: perlchunks.h plperl_opmask.h plperl_helpers.h + +plperl_opmask.h: plperl_opmask.pl + @if [ x"$(perl_privlibexp)" = x"" ]; then echo "configure switch --with-perl was not specified."; exit 1; fi + $(PERL) $< $@ + +perlchunks.h: $(PERLCHUNKS) + @if [ x"$(perl_privlibexp)" = x"" ]; then echo "configure switch --with-perl was not specified."; exit 1; fi + $(PERL) $(srcdir)/text2macro.pl --strip='^(\#.*|\s*)$$' $^ > $@ + +all: all-lib + +%.c: %.xs + @if [ x"$(perl_privlibexp)" = x"" ]; then echo "configure switch --with-perl was not specified."; exit 1; fi +# xsubpp -output option is required for coverage+vpath, but requires Perl 5.9.3 +ifeq ($(enable_coverage)$(vpath_build),yesyes) + $(PERL) $(XSUBPPDIR)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap -output $@ $< +else + $(PERL) $(XSUBPPDIR)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ +endif + + +install: all install-lib install-data + +installdirs: installdirs-lib + $(MKDIR_P) '$(DESTDIR)$(datadir)/extension' '$(DESTDIR)$(includedir_server)' + +uninstall: uninstall-lib uninstall-data + +install-data: installdirs + $(INSTALL_DATA) $(addprefix $(srcdir)/, $(DATA)) '$(DESTDIR)$(datadir)/extension/' + $(INSTALL_DATA) $(srcdir)/plperl.h $(srcdir)/ppport.h $(srcdir)/plperl_helpers.h '$(DESTDIR)$(includedir_server)' + +uninstall-data: + rm -f $(addprefix '$(DESTDIR)$(datadir)/extension'/, $(notdir $(DATA))) + rm -f $(addprefix '$(DESTDIR)$(includedir_server)'/, plperl.h ppport.h) + +.PHONY: install-data uninstall-data + + +check: submake + $(pg_regress_check) $(REGRESS_OPTS) $(REGRESS) + +installcheck: submake + $(pg_regress_installcheck) $(REGRESS_OPTS) $(REGRESS) + +.PHONY: submake +submake: + $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X) + +clean distclean maintainer-clean: clean-lib + rm -f SPI.c Util.c $(OBJS) perlchunks.h plperl_opmask.h + rm -rf $(pg_regress_clean_files) +ifeq ($(PORTNAME), win32) + rm -f $(perlwithver).def +endif diff --git a/src/pl/plperl/README b/src/pl/plperl/README new file mode 100644 index 0000000..e61dd57 --- /dev/null +++ b/src/pl/plperl/README @@ -0,0 +1,10 @@ +src/pl/plperl/README + +PL/Perl allows you to write PostgreSQL functions and procedures in +Perl. To include PL/Perl in the build use './configure --with-perl'. +To build from this directory use 'make all; make install'. libperl +must have been built as a shared library, which is usually not the +case in standard installations. + +Consult the PostgreSQL User's Guide and the INSTALL file in the +top-level directory of the source distribution for more information. diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs new file mode 100644 index 0000000..b2db3bd --- /dev/null +++ b/src/pl/plperl/SPI.xs @@ -0,0 +1,163 @@ +/********************************************************************** + * PostgreSQL::InServer::SPI + * + * SPI interface for plperl. + * + * src/pl/plperl/SPI.xs + * + **********************************************************************/ + +/* this must be first: */ +#include "postgres.h" + +/* perl stuff */ +#define PG_NEED_PERL_XSUB_H +#include "plperl.h" +#include "plperl_helpers.h" + + +MODULE = PostgreSQL::InServer::SPI PREFIX = spi_ + +PROTOTYPES: ENABLE +VERSIONCHECK: DISABLE + +SV* +spi_spi_exec_query(sv, ...) + SV* sv; + PREINIT: + HV *ret_hash; + int limit = 0; + char *query; + CODE: + if (items > 2) + croak("Usage: spi_exec_query(query, limit) " + "or spi_exec_query(query)"); + if (items == 2) + limit = SvIV(ST(1)); + query = sv2cstr(sv); + ret_hash = plperl_spi_exec(query, limit); + pfree(query); + RETVAL = newRV_noinc((SV*) ret_hash); + OUTPUT: + RETVAL + +void +spi_return_next(rv) + SV *rv; + CODE: + plperl_return_next(rv); + +SV * +spi_spi_query(sv) + SV *sv; + CODE: + char* query = sv2cstr(sv); + RETVAL = plperl_spi_query(query); + pfree(query); + OUTPUT: + RETVAL + +SV * +spi_spi_fetchrow(sv) + SV* sv; + CODE: + char* cursor = sv2cstr(sv); + RETVAL = plperl_spi_fetchrow(cursor); + pfree(cursor); + OUTPUT: + RETVAL + +SV* +spi_spi_prepare(sv, ...) + SV* sv; + CODE: + int i; + SV** argv; + char* query = sv2cstr(sv); + if (items < 1) + Perl_croak(aTHX_ "Usage: spi_prepare(query, ...)"); + argv = ( SV**) palloc(( items - 1) * sizeof(SV*)); + for ( i = 1; i < items; i++) + argv[i - 1] = ST(i); + RETVAL = plperl_spi_prepare(query, items - 1, argv); + pfree( argv); + pfree(query); + OUTPUT: + RETVAL + +SV* +spi_spi_exec_prepared(sv, ...) + SV* sv; + PREINIT: + HV *ret_hash; + CODE: + HV *attr = NULL; + int i, offset = 1, argc; + SV ** argv; + char *query = sv2cstr(sv); + if ( items < 1) + Perl_croak(aTHX_ "Usage: spi_exec_prepared(query, [\\%%attr,] " + "[\\@bind_values])"); + if ( items > 1 && SvROK( ST( 1)) && SvTYPE( SvRV( ST( 1))) == SVt_PVHV) + { + attr = ( HV*) SvRV(ST(1)); + offset++; + } + argc = items - offset; + argv = ( SV**) palloc( argc * sizeof(SV*)); + for ( i = 0; offset < items; offset++, i++) + argv[i] = ST(offset); + ret_hash = plperl_spi_exec_prepared(query, attr, argc, argv); + RETVAL = newRV_noinc((SV*)ret_hash); + pfree( argv); + pfree(query); + OUTPUT: + RETVAL + +SV* +spi_spi_query_prepared(sv, ...) + SV * sv; + CODE: + int i; + SV ** argv; + char *query = sv2cstr(sv); + if ( items < 1) + Perl_croak(aTHX_ "Usage: spi_query_prepared(query, " + "[\\@bind_values])"); + argv = ( SV**) palloc(( items - 1) * sizeof(SV*)); + for ( i = 1; i < items; i++) + argv[i - 1] = ST(i); + RETVAL = plperl_spi_query_prepared(query, items - 1, argv); + pfree( argv); + pfree(query); + OUTPUT: + RETVAL + +void +spi_spi_freeplan(sv) + SV *sv; + CODE: + char *query = sv2cstr(sv); + plperl_spi_freeplan(query); + pfree(query); + +void +spi_spi_cursor_close(sv) + SV *sv; + CODE: + char *cursor = sv2cstr(sv); + plperl_spi_cursor_close(cursor); + pfree(cursor); + +void +spi_spi_commit() + CODE: + plperl_spi_commit(); + +void +spi_spi_rollback() + CODE: + plperl_spi_rollback(); + +BOOT: + items = 0; /* avoid 'unused variable' warning */ diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs new file mode 100644 index 0000000..47eba59 --- /dev/null +++ b/src/pl/plperl/Util.xs @@ -0,0 +1,189 @@ +/********************************************************************** + * PostgreSQL::InServer::Util + * + * src/pl/plperl/Util.xs + * + * Defines plperl interfaces for general-purpose utilities. + * This module is bootstrapped as soon as an interpreter is initialized. + * 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 */ + +/* perl stuff */ +#define PG_NEED_PERL_XSUB_H +#include "plperl.h" +#include "plperl_helpers.h" + + +static text * +sv2text(SV *sv) +{ + char *str = sv2cstr(sv); + text *text; + + text = cstring_to_text(str); + pfree(str); + return text; +} + +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, msg) + int level + SV *msg + CODE: + if (level > ERROR) /* no PANIC allowed thanks */ + level = ERROR; + if (level < DEBUG5) + level = DEBUG5; + plperl_util_elog(level, msg); + +SV * +util_quote_literal(sv) + SV *sv + CODE: + if (!sv || !SvOK(sv)) { + RETVAL = &PL_sv_undef; + } + else { + text *arg = sv2text(sv); + text *quoted = DatumGetTextPP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg))); + char *str; + + pfree(arg); + str = text_to_cstring(quoted); + RETVAL = cstr2sv(str); + pfree(str); + } + OUTPUT: + RETVAL + +SV * +util_quote_nullable(sv) + SV *sv + CODE: + if (!sv || !SvOK(sv)) + { + RETVAL = cstr2sv("NULL"); + } + else + { + text *arg = sv2text(sv); + text *quoted = DatumGetTextPP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg))); + char *str; + + pfree(arg); + str = text_to_cstring(quoted); + RETVAL = cstr2sv(str); + pfree(str); + } + OUTPUT: + RETVAL + +SV * +util_quote_ident(sv) + SV *sv + PREINIT: + text *arg; + text *quoted; + char *str; + CODE: + arg = sv2text(sv); + quoted = DatumGetTextPP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg))); + + pfree(arg); + str = text_to_cstring(quoted); + RETVAL = cstr2sv(str); + pfree(str); + OUTPUT: + RETVAL + +SV * +util_decode_bytea(sv) + SV *sv + PREINIT: + char *arg; + text *ret; + CODE: + arg = SvPVbyte_nolen(sv); + ret = DatumGetTextPP(DirectFunctionCall1(byteain, PointerGetDatum(arg))); + /* not cstr2sv because this is raw bytes not utf8'able */ + RETVAL = newSVpvn(VARDATA_ANY(ret), VARSIZE_ANY_EXHDR(ret)); + OUTPUT: + RETVAL + +SV * +util_encode_bytea(sv) + SV *sv + PREINIT: + text *arg; + char *ret; + STRLEN len; + CODE: + /* not sv2text because this is raw bytes not utf8'able */ + ret = SvPVbyte(sv, len); + arg = cstring_to_text_with_len(ret, len); + ret = DatumGetCString(DirectFunctionCall1(byteaout, PointerGetDatum(arg))); + RETVAL = cstr2sv(ret); + OUTPUT: + RETVAL + +SV * +looks_like_number(sv) + SV *sv + CODE: + if (!SvOK(sv)) + RETVAL = &PL_sv_undef; + else if ( looks_like_number(sv) ) + RETVAL = &PL_sv_yes; + else + RETVAL = &PL_sv_no; + OUTPUT: + RETVAL + +SV * +encode_typed_literal(sv, typname) + SV *sv + char *typname; + PREINIT: + char *outstr; + CODE: + outstr = plperl_sv_to_literal(sv, typname); + if (outstr == NULL) + RETVAL = &PL_sv_undef; + else + RETVAL = cstr2sv(outstr); + 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 new file mode 100644 index 0000000..d8a1ff5 --- /dev/null +++ b/src/pl/plperl/expected/plperl.out @@ -0,0 +1,794 @@ +-- +-- Test result value processing +-- +CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ +return undef; +$$ LANGUAGE plperl; +SELECT perl_int(11); + perl_int +---------- + +(1 row) + +SELECT * FROM perl_int(42); + perl_int +---------- + +(1 row) + +CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ +return $_[0] + 1; +$$ LANGUAGE plperl; +SELECT perl_int(11); + perl_int +---------- + 12 +(1 row) + +SELECT * FROM perl_int(42); + perl_int +---------- + 43 +(1 row) + +CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ +return undef; +$$ LANGUAGE plperl; +SELECT perl_set_int(5); + perl_set_int +-------------- +(0 rows) + +SELECT * FROM perl_set_int(5); + perl_set_int +-------------- +(0 rows) + +CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ +return [0..$_[0]]; +$$ LANGUAGE plperl; +SELECT perl_set_int(5); + perl_set_int +-------------- + 0 + 1 + 2 + 3 + 4 + 5 +(6 rows) + +SELECT * FROM perl_set_int(5); + perl_set_int +-------------- + 0 + 1 + 2 + 3 + 4 + 5 +(6 rows) + +CREATE TYPE testnestperl AS (f5 integer[]); +CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl); +CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ + return undef; +$$ LANGUAGE plperl; +SELECT perl_row(); + perl_row +---------- + +(1 row) + +SELECT * FROM perl_row(); + f1 | f2 | f3 | f4 +----+----+----+---- + | | | +(1 row) + +CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } }; +$$ LANGUAGE plperl; +SELECT perl_row(); + perl_row +--------------------------- + (1,hello,world,"({{1}})") +(1 row) + +SELECT * FROM perl_row(); + f1 | f2 | f3 | f4 +----+-------+-------+--------- + 1 | hello | world | ({{1}}) +(1 row) + +-- test returning a composite literal +CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$ + return '(1,hello,world,"({{1}})")'; +$$ LANGUAGE plperl; +SELECT perl_row_lit(); + perl_row_lit +--------------------------- + (1,hello,world,"({{1}})") +(1 row) + +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return undef; +$$ LANGUAGE plperl; +SELECT perl_set(); + perl_set +---------- +(0 rows) + +SELECT * FROM perl_set(); + f1 | f2 | f3 | f4 +----+----+----+---- +(0 rows) + +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + undef, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} }, + { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }}, + { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }}, + { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }}, + ]; +$$ LANGUAGE plperl; +SELECT perl_set(); +ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash +CONTEXT: PL/Perl function "perl_set" +SELECT * FROM perl_set(); +ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash +CONTEXT: PL/Perl function "perl_set" +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL', 'f4' => undef }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} }, + { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }}, + { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }}, + { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }}, + { f1 => 7, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => '({1})' }, + ]; +$$ LANGUAGE plperl; +SELECT perl_set(); + perl_set +--------------------------- + (1,Hello,World,) + (2,Hello,PostgreSQL,) + (3,Hello,PL/Perl,"()") + (4,Hello,PL/Perl,"()") + (5,Hello,PL/Perl,"({1})") + (6,Hello,PL/Perl,"({1})") + (7,Hello,PL/Perl,"({1})") +(7 rows) + +SELECT * FROM perl_set(); + f1 | f2 | f3 | f4 +----+-------+------------+------- + 1 | Hello | World | + 2 | Hello | PostgreSQL | + 3 | Hello | PL/Perl | () + 4 | Hello | PL/Perl | () + 5 | Hello | PL/Perl | ({1}) + 6 | Hello | PL/Perl | ({1}) + 7 | Hello | PL/Perl | ({1}) +(7 rows) + +CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ + return undef; +$$ LANGUAGE plperl; +SELECT perl_record(); + perl_record +------------- + +(1 row) + +SELECT * FROM perl_record(); +ERROR: a column definition list is required for functions returning "record" +LINE 1: SELECT * FROM perl_record(); + ^ +SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); + f1 | f2 | f3 | f4 +----+----+----+---- + | | | +(1 row) + +CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } }; +$$ LANGUAGE plperl; +SELECT perl_record(); +ERROR: function returning record called in context that cannot accept type record +CONTEXT: PL/Perl function "perl_record" +SELECT * FROM perl_record(); +ERROR: a column definition list is required for functions returning "record" +LINE 1: SELECT * FROM perl_record(); + ^ +SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); + f1 | f2 | f3 | f4 +----+-------+-------+------- + 1 | hello | world | ({1}) +(1 row) + +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return undef; +$$ LANGUAGE plperl; +SELECT perl_record_set(); + perl_record_set +----------------- +(0 rows) + +SELECT * FROM perl_record_set(); +ERROR: a column definition list is required for functions returning "record" +LINE 1: SELECT * FROM perl_record_set(); + ^ +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + f1 | f2 | f3 +----+----+---- +(0 rows) + +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + undef, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; +SELECT perl_record_set(); +ERROR: function returning record called in context that cannot accept type record +CONTEXT: PL/Perl function "perl_record_set" +SELECT * FROM perl_record_set(); +ERROR: a column definition list is required for functions returning "record" +LINE 1: SELECT * FROM perl_record_set(); + ^ +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); +ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash +CONTEXT: PL/Perl function "perl_record_set" +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; +SELECT perl_record_set(); +ERROR: function returning record called in context that cannot accept type record +CONTEXT: PL/Perl function "perl_record_set" +SELECT * FROM perl_record_set(); +ERROR: a column definition list is required for functions returning "record" +LINE 1: SELECT * FROM perl_record_set(); + ^ +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + f1 | f2 | f3 +----+-------+------------ + 1 | Hello | World + 2 | Hello | PostgreSQL + 3 | Hello | PL/Perl +(3 rows) + +CREATE OR REPLACE FUNCTION +perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world'}; +$$ LANGUAGE plperl; +SELECT perl_out_params(); + perl_out_params +----------------- + (1,hello,world) +(1 row) + +SELECT * FROM perl_out_params(); + f1 | f2 | f3 +----+-------+------- + 1 | hello | world +(1 row) + +SELECT (perl_out_params()).f2; + f2 +------- + hello +(1 row) + +CREATE OR REPLACE FUNCTION +perl_out_params_set(out f1 integer, out f2 text, out f3 text) +RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; +SELECT perl_out_params_set(); + perl_out_params_set +---------------------- + (1,Hello,World) + (2,Hello,PostgreSQL) + (3,Hello,PL/Perl) +(3 rows) + +SELECT * FROM perl_out_params_set(); + f1 | f2 | f3 +----+-------+------------ + 1 | Hello | World + 2 | Hello | PostgreSQL + 3 | Hello | PL/Perl +(3 rows) + +SELECT (perl_out_params_set()).f3; + f3 +------------ + World + PostgreSQL + PL/Perl +(3 rows) + +-- +-- Check behavior with erroneous return values +-- +CREATE TYPE footype AS (x INTEGER, y INTEGER); +CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$ +return [ + {x => 1, y => 2}, + {x => 3, y => 4} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_good(); + x | y +---+--- + 1 | 2 + 3 | 4 +(2 rows) + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: Perl hash contains nonexistent column "z" +CONTEXT: PL/Perl function "foo_bad" +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return 42; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: malformed record literal: "42" +DETAIL: Missing left parenthesis. +CONTEXT: PL/Perl function "foo_bad" +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_bad(); +ERROR: cannot convert Perl array to non-array type footype +CONTEXT: PL/Perl function "foo_bad" +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return 42; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: set-returning PL/Perl function must return reference to array or use return_next +CONTEXT: PL/Perl function "foo_set_bad" +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: set-returning PL/Perl function must return reference to array or use return_next +CONTEXT: PL/Perl function "foo_set_bad" +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: SETOF-composite-returning PL/Perl function must call return_next with reference to hash +CONTEXT: PL/Perl function "foo_set_bad" +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + {y => 3, z => 4} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_set_bad(); +ERROR: Perl hash contains nonexistent column "z" +CONTEXT: PL/Perl function "foo_set_bad" +CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y); +CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ + return {x => 3, y => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_ordered(); + x | y +---+--- + 3 | 4 +(1 row) + +CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ + return {x => 5, y => 4}; +$$ LANGUAGE plperl; +SELECT * FROM foo_ordered(); -- fail +ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check" +CONTEXT: PL/Perl function "foo_ordered" +CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ +return [ + {x => 3, y => 4}, + {x => 4, y => 7} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_ordered_set(); + x | y +---+--- + 3 | 4 + 4 | 7 +(2 rows) + +CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ +return [ + {x => 3, y => 4}, + {x => 9, y => 7} +]; +$$ LANGUAGE plperl; +SELECT * FROM foo_ordered_set(); -- fail +ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check" +CONTEXT: PL/Perl function "foo_ordered_set" +-- +-- Check passing a tuple argument +-- +CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; +SELECT perl_get_field((11,12), 'x'); + perl_get_field +---------------- + 11 +(1 row) + +SELECT perl_get_field((11,12), 'y'); + perl_get_field +---------------- + 12 +(1 row) + +SELECT perl_get_field((11,12), 'z'); + perl_get_field +---------------- + +(1 row) + +CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; +SELECT perl_get_cfield((11,12), 'x'); + perl_get_cfield +----------------- + 11 +(1 row) + +SELECT perl_get_cfield((11,12), 'y'); + perl_get_cfield +----------------- + 12 +(1 row) + +SELECT perl_get_cfield((12,11), 'x'); -- fail +ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check" +CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; +SELECT perl_get_rfield((11,12), 'f1'); + perl_get_rfield +----------------- + 11 +(1 row) + +SELECT perl_get_rfield((11,12)::footype, 'y'); + perl_get_rfield +----------------- + 12 +(1 row) + +SELECT perl_get_rfield((11,12)::orderedfootype, 'x'); + perl_get_rfield +----------------- + 11 +(1 row) + +SELECT perl_get_rfield((12,11)::orderedfootype, 'x'); -- fail +ERROR: value for domain orderedfootype violates check constraint "orderedfootype_check" +-- +-- Test return_next +-- +CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$ +my $i = 0; +for ("World", "PostgreSQL", "PL/Perl") { + return_next({f1=>++$i, f2=>'Hello', f3=>$_}); +} +return; +$$ language plperl; +SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT); + f1 | f2 | f3 +----+-------+------------ + 1 | Hello | World + 2 | Hello | PostgreSQL + 3 | Hello | PL/Perl +(3 rows) + +-- +-- Test spi_query/spi_fetchrow +-- +CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$ +my $x = spi_query("select 1 as a union select 2 as a"); +while (defined (my $y = spi_fetchrow($x))) { + return_next($y->{a}); +} +return; +$$ LANGUAGE plperl; +SELECT * from perl_spi_func(); + perl_spi_func +--------------- + 1 + 2 +(2 rows) + +-- +-- Test spi_fetchrow abort +-- +CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$ +my $x = spi_query("select 1 as a union select 2 as a"); +spi_cursor_close( $x); +return 0; +$$ LANGUAGE plperl; +SELECT * from perl_spi_func2(); + perl_spi_func2 +---------------- + 0 +(1 row) + +--- +--- Test recursion via SPI +--- +CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl +AS $$ + + my $i = shift; + foreach my $x (1..$i) + { + return_next "hello $x"; + } + if ($i > 2) + { + my $z = $i-1; + my $cursor = spi_query("select * from recurse($z)"); + while (defined(my $row = spi_fetchrow($cursor))) + { + return_next "recurse $i: $row->{recurse}"; + } + } + return undef; + +$$; +SELECT * FROM recurse(2); + recurse +--------- + hello 1 + hello 2 +(2 rows) + +SELECT * FROM recurse(3); + recurse +-------------------- + hello 1 + hello 2 + hello 3 + recurse 3: hello 1 + recurse 3: hello 2 +(5 rows) + +--- +--- Test array return +--- +CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][] +LANGUAGE plperl as $$ + return [['a"b',undef,'c,d'],['e\\f',undef,'g']]; +$$; +SELECT array_of_text(); + array_of_text +--------------------------------------- + {{"a\"b",NULL,"c,d"},{"e\\f",NULL,g}} +(1 row) + +-- +-- Test spi_prepare/spi_exec_prepared/spi_freeplan +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$ + my $x = spi_prepare('select $1 AS a', 'INTEGER'); + my $q = spi_exec_prepared( $x, $_[0] + 1); + spi_freeplan($x); +return $q->{rows}->[0]->{a}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared(42); + perl_spi_prepared +------------------- + 43 +(1 row) + +-- +-- Test spi_prepare/spi_query_prepared/spi_freeplan +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$ + my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4'); + my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]); + while (defined (my $y = spi_fetchrow($q))) { + return_next $y->{a}; + } + spi_freeplan($x); + return; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared_set(1,2); + perl_spi_prepared_set +----------------------- + 2 + 4 +(2 rows) + +-- +-- Test prepare with a type with spaces +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$ + my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION'); + my $q = spi_query_prepared($x,$_[0]); + my $result; + while (defined (my $y = spi_fetchrow($q))) { + $result = $y->{a}; + } + spi_freeplan($x); + return $result; +$$ LANGUAGE plperl; +SELECT perl_spi_prepared_double(4.35) as "double precision"; + double precision +------------------ + 43.5 +(1 row) + +-- +-- Test with a bad type +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$ + my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist'); + my $q = spi_query_prepared($x,$_[0]); + my $result; + while (defined (my $y = spi_fetchrow($q))) { + $result = $y->{a}; + } + spi_freeplan($x); + return $result; +$$ LANGUAGE plperl; +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 with a row type +CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$ + my $x = spi_prepare('select $1::footype AS a', 'footype'); + my $q = spi_exec_prepared( $x, '(1, 2)'); + spi_freeplan($x); +return $q->{rows}->[0]->{a}->{x}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared(); + perl_spi_prepared +------------------- + 1 +(1 row) + +CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$ + my $footype = shift; + my $x = spi_prepare('select $1 AS a', 'footype'); + my $q = spi_exec_prepared( $x, {}, $footype ); + spi_freeplan($x); +return $q->{rows}->[0]->{a}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared_row('(1, 2)'); + x | y +---+--- + 1 | 2 +(1 row) + +-- simple test of a DO block +DO $$ + $a = 'This is a test'; + elog(NOTICE, $a); +$$ LANGUAGE plperl; +NOTICE: This is a test +-- check that restricted operations are rejected in a plperl DO block +DO $$ system("/nonesuch"); $$ LANGUAGE plperl; +ERROR: 'system' trapped by operation mask at line 1. +CONTEXT: PL/Perl anonymous code block +DO $$ qx("/nonesuch"); $$ LANGUAGE plperl; +ERROR: 'quoted execution (``, qx)' trapped by operation mask at line 1. +CONTEXT: PL/Perl anonymous code block +DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl; +ERROR: 'open' trapped by operation mask at line 1. +CONTEXT: PL/Perl anonymous code block +-- check that eval is allowed and eval'd restricted ops are caught +DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl; +WARNING: Caught: 'chdir' trapped by operation mask at line 1. +-- check that compiling do (dofile opcode) is allowed +-- but that executing it for a file not already loaded (via require) dies +DO $$ warn do "/dev/null"; $$ LANGUAGE plperl; +ERROR: Unable to load /dev/null into plperl 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 +-- check that we can "use warnings" (in this case to turn a warn into an error) +-- yields "ERROR: Useless use of sort in scalar context." +DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl; +ERROR: Useless use of sort in scalar context at line 1. +CONTEXT: PL/Perl anonymous code block +-- make sure functions marked as VOID without an explicit return work +CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$ + $_SHARED{myquote} = sub { + my $arg = shift; + $arg =~ s/(['\\])/\\$1/g; + return "'$arg'"; + }; +$$ LANGUAGE plperl; +SELECT myfuncs(); + myfuncs +--------- + +(1 row) + +-- make sure we can't return an array as a scalar +CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$ + return ['array']; +$$ LANGUAGE plperl; +SELECT text_arrayref(); +ERROR: cannot convert Perl array to non-array type text +CONTEXT: PL/Perl function "text_arrayref" +--- make sure we can't return a hash as a scalar +CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$ + return {'hash'=>1}; +$$ LANGUAGE plperl; +SELECT text_hashref(); +ERROR: cannot convert Perl hash to non-composite type text +CONTEXT: PL/Perl function "text_hashref" +---- make sure we can't return a blessed object as a scalar +CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$ + return bless({}, 'Fake::Object'); +$$ LANGUAGE plperl; +SELECT text_obj(); +ERROR: cannot convert Perl hash to non-composite type text +CONTEXT: PL/Perl function "text_obj" +-- test looking through a scalar ref +CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$ + my $str = 'str'; + return \$str; +$$ LANGUAGE plperl; +SELECT text_scalarref(); + text_scalarref +---------------- + str +(1 row) + +-- check safe behavior when a function body is replaced during execution +CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$ + spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;'); + spi_exec_query('select self_modify(42) AS a'); + return $_[0] * 2; +$$ LANGUAGE plperl; +SELECT self_modify(42); + self_modify +------------- + 84 +(1 row) + +SELECT self_modify(42); + self_modify +------------- + 126 +(1 row) + diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out new file mode 100644 index 0000000..6347b52 --- /dev/null +++ b/src/pl/plperl/expected/plperl_array.out @@ -0,0 +1,233 @@ +CREATE OR REPLACE FUNCTION plperl_sum_array(INTEGER[]) RETURNS text AS $$ + my $array_arg = shift; + my $result = 0; + my @arrays; + + push @arrays, @$array_arg; + + while (@arrays > 0) { + my $el = shift @arrays; + if (is_array_ref($el)) { + push @arrays, @$el; + } else { + $result += $el; + } + } + return $result.' '.$array_arg; +$$ LANGUAGE plperl; +select plperl_sum_array('{1,2,NULL}'); + plperl_sum_array +------------------ + 3 {1,2,NULL} +(1 row) + +select plperl_sum_array('{}'); + plperl_sum_array +------------------ + 0 {} +(1 row) + +select plperl_sum_array('{{1,2,3}, {4,5,6}}'); + plperl_sum_array +---------------------- + 21 {{1,2,3},{4,5,6}} +(1 row) + +select plperl_sum_array('{{{1,2,3}, {4,5,6}}, {{7,8,9}, {10,11,12}}}'); + plperl_sum_array +--------------------------------------------- + 78 {{{1,2,3},{4,5,6}},{{7,8,9},{10,11,12}}} +(1 row) + +-- check whether we can handle arrays of maximum dimension (6) +select plperl_sum_array(ARRAY[[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]], +[[13,14],[15,16]]]], +[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]], +[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],[[13,14],[15,16]]]], +[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]]]); + plperl_sum_array +------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ + 1056 {{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}},{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}},{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}} +(1 row) + +-- what would we do with the arrays exceeding maximum dimension (7) +select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}}, +{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}, +{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}, +{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}, +{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}}' +); +ERROR: number of array dimensions (7) exceeds the maximum allowed (6) +LINE 1: select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{... + ^ +select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}'); +ERROR: malformed array literal: "{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}" +LINE 1: select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {1... + ^ +DETAIL: Multidimensional arrays must have sub-arrays with matching dimensions. +CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$ + my $array_arg = shift; + my $result = ""; + my @arrays; + + push @arrays, @$array_arg; + while (@arrays > 0) { + my $el = shift @arrays; + if (is_array_ref($el)) { + push @arrays, @$el; + } else { + $result .= $el; + } + } + return $result.' '.$array_arg; +$$ LANGUAGE plperl; +select plperl_concat('{"NULL","NULL","NULL''"}'); + plperl_concat +------------------------------------- + NULLNULLNULL' {"NULL","NULL",NULL'} +(1 row) + +select plperl_concat('{{NULL,NULL,NULL}}'); + plperl_concat +--------------------- + {{NULL,NULL,NULL}} +(1 row) + +select plperl_concat('{"hello"," ","world!"}'); + plperl_concat +--------------------------------- + hello world! {hello," ",world!} +(1 row) + +-- array of rows -- +CREATE TYPE foo AS (bar INTEGER, baz TEXT); +CREATE OR REPLACE FUNCTION plperl_array_of_rows(foo[]) RETURNS TEXT AS $$ + my $array_arg = shift; + my $result = ""; + + for my $row_ref (@$array_arg) { + die "not a hash reference" unless (ref $row_ref eq "HASH"); + $result .= $row_ref->{bar}." items of ".$row_ref->{baz}.";"; + } + return $result .' '. $array_arg; +$$ LANGUAGE plperl; +select plperl_array_of_rows(ARRAY[ ROW(2, 'coffee'), ROW(0, 'sugar')]::foo[]); + plperl_array_of_rows +---------------------------------------------------------------- + 2 items of coffee;0 items of sugar; {"(2,coffee)","(0,sugar)"} +(1 row) + +-- composite type containing arrays +CREATE TYPE rowfoo AS (bar INTEGER, baz INTEGER[]); +CREATE OR REPLACE FUNCTION plperl_sum_row_elements(rowfoo) RETURNS TEXT AS $$ + my $row_ref = shift; + my $result; + + if (ref $row_ref ne 'HASH') { + $result = 0; + } + else { + $result = $row_ref->{bar}; + die "not an array reference".ref ($row_ref->{baz}) + unless (is_array_ref($row_ref->{baz})); + # process a single-dimensional array + foreach my $elem (@{$row_ref->{baz}}) { + $result += $elem unless ref $elem; + } + } + return $result; +$$ LANGUAGE plperl; +select plperl_sum_row_elements(ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo); + plperl_sum_row_elements +------------------------- + 55 +(1 row) + +-- composite type containing array of another composite type, which, in order, +-- contains an array of integers. +CREATE TYPE rowbar AS (foo rowfoo[]); +CREATE OR REPLACE FUNCTION plperl_sum_array_of_rows(rowbar) RETURNS TEXT AS $$ + my $rowfoo_ref = shift; + my $result = 0; + + if (ref $rowfoo_ref eq 'HASH') { + my $row_array_ref = $rowfoo_ref->{foo}; + if (is_array_ref($row_array_ref)) { + foreach my $row_ref (@{$row_array_ref}) { + if (ref $row_ref eq 'HASH') { + $result += $row_ref->{bar}; + die "not an array reference".ref ($row_ref->{baz}) + unless (is_array_ref($row_ref->{baz})); + foreach my $elem (@{$row_ref->{baz}}) { + $result += $elem unless ref $elem; + } + } + else { + die "element baz is not a reference to a rowfoo"; + } + } + } else { + die "not a reference to an array of rowfoo elements" + } + } else { + die "not a reference to type rowbar"; + } + return $result; +$$ LANGUAGE plperl; +select plperl_sum_array_of_rows(ROW(ARRAY[ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo, +ROW(11, ARRAY[12,13,14,15,16,17,18,19,20])::rowfoo])::rowbar); + plperl_sum_array_of_rows +-------------------------- + 210 +(1 row) + +-- check arrays as out parameters +CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$ + return [[1,2,3],[4,5,6]]; +$$ LANGUAGE plperl; +select plperl_arrays_out(); + plperl_arrays_out +------------------- + {{1,2,3},{4,5,6}} +(1 row) + +-- check that we can return the array we passed in +CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$ + return shift; +$$ LANGUAGE plperl; +select plperl_arrays_inout('{{1}, {2}, {3}}'); + plperl_arrays_inout +--------------------- + {{1},{2},{3}} +(1 row) + +-- check that we can return an array literal +CREATE OR REPLACE FUNCTION plperl_arrays_inout_l(INTEGER[]) returns INTEGER[] AS $$ + return shift.''; # stringify it +$$ LANGUAGE plperl; +select plperl_arrays_inout_l('{{1}, {2}, {3}}'); + plperl_arrays_inout_l +----------------------- + {{1},{2},{3}} +(1 row) + +-- make sure setof works +create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$ + my $arr = shift; + for my $r (@$arr) { + return_next $r; + } + return undef; +$$; +select perl_setof_array('{{1}, {2}, {3}}'); + perl_setof_array +------------------ + {1} + {2} + {3} +(3 rows) + diff --git a/src/pl/plperl/expected/plperl_call.out b/src/pl/plperl/expected/plperl_call.out new file mode 100644 index 0000000..c55c59c --- /dev/null +++ b/src/pl/plperl/expected/plperl_call.out @@ -0,0 +1,54 @@ +CREATE PROCEDURE test_proc1() +LANGUAGE plperl +AS $$ +undef; +$$; +CALL test_proc1(); +CREATE PROCEDURE test_proc2() +LANGUAGE plperl +AS $$ +return 5 +$$; +CALL test_proc2(); +CREATE TABLE test1 (a int); +CREATE PROCEDURE test_proc3(x int) +LANGUAGE plperl +AS $$ +spi_exec_query("INSERT INTO test1 VALUES ($_[0])"); +$$; +CALL test_proc3(55); +SELECT * FROM test1; + a +---- + 55 +(1 row) + +-- output arguments +CREATE PROCEDURE test_proc5(INOUT a text) +LANGUAGE plperl +AS $$ +my ($a) = @_; +return { a => "$a+$a" }; +$$; +CALL test_proc5('abc'); + a +--------- + abc+abc +(1 row) + +CREATE PROCEDURE test_proc6(a int, INOUT b int, INOUT c int) +LANGUAGE plperl +AS $$ +my ($a, $b, $c) = @_; +return { b => $b * $a, c => $c * $a }; +$$; +CALL test_proc6(2, 3, 4); + b | c +---+--- + 6 | 8 +(1 row) + +DROP PROCEDURE test_proc1; +DROP PROCEDURE test_proc2; +DROP PROCEDURE test_proc3; +DROP TABLE test1; diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out new file mode 100644 index 0000000..a6d35cb --- /dev/null +++ b/src/pl/plperl/expected/plperl_elog.out @@ -0,0 +1,112 @@ +-- test warnings and errors from plperl +create or replace function perl_elog(text) returns void language plperl as $$ + + my $msg = shift; + elog(NOTICE,$msg); + +$$; +select perl_elog('explicit elog'); +NOTICE: explicit elog + perl_elog +----------- + +(1 row) + +create or replace function perl_warn(text) returns void language plperl as $$ + + my $msg = shift; + warn($msg); + +$$; +select perl_warn('implicit elog via warn'); +WARNING: implicit elog via warn at line 4. + perl_warn +----------- + +(1 row) + +-- test strict mode on/off +SET plperl.use_strict = true; +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global = 2; + return 'uses_global worked'; + +$$; +ERROR: Global symbol "$global" requires explicit package name at line 3. +Global symbol "$other_global" requires explicit package name at line 4. +CONTEXT: compilation of PL/Perl function "uses_global" +select uses_global(); +ERROR: function uses_global() does not exist +LINE 1: select uses_global(); + ^ +HINT: No function matches the given name and argument types. You might need to add explicit type casts. +SET plperl.use_strict = false; +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global=2; + return 'uses_global worked'; + +$$; +select uses_global(); + uses_global +-------------------- + uses_global worked +(1 row) + +-- make sure we don't choke on readonly values +do language plperl $$ elog(NOTICE, ${^TAINT}); $$; +NOTICE: 0 +-- test recovery after "die" +create or replace function just_die() returns void language plperl AS $$ +die "just die"; +$$; +select just_die(); +ERROR: just die at line 2. +CONTEXT: PL/Perl function "just_die" +create or replace function die_caller() returns int language plpgsql as $$ +BEGIN + BEGIN + PERFORM just_die(); + EXCEPTION WHEN OTHERS THEN + RAISE NOTICE 'caught die'; + END; + RETURN 1; +END; +$$; +select die_caller(); +NOTICE: caught die + die_caller +------------ + 1 +(1 row) + +create or replace function indirect_die_caller() returns int language plperl as $$ +my $prepared = spi_prepare('SELECT die_caller() AS fx'); +my $a = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +my $b = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +return $a + $b; +$$; +select indirect_die_caller(); +NOTICE: caught die +NOTICE: caught die + indirect_die_caller +--------------------- + 2 +(1 row) + +-- Test non-ASCII error messages +-- +-- Note: this test case is known to fail if the database encoding is +-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to +-- U+00A0 (no-break space) in those encodings. However, testing with +-- plain ASCII data would be rather useless, so we must live with that. +SET client_encoding TO UTF8; +create or replace function error_with_nbsp() returns void language plperl as $$ + elog(ERROR, "this message contains a no-break space"); +$$; +select error_with_nbsp(); +ERROR: this message contains a no-break space at line 2. +CONTEXT: PL/Perl function "error_with_nbsp" diff --git a/src/pl/plperl/expected/plperl_elog_1.out b/src/pl/plperl/expected/plperl_elog_1.out new file mode 100644 index 0000000..85aa460 --- /dev/null +++ b/src/pl/plperl/expected/plperl_elog_1.out @@ -0,0 +1,112 @@ +-- test warnings and errors from plperl +create or replace function perl_elog(text) returns void language plperl as $$ + + my $msg = shift; + elog(NOTICE,$msg); + +$$; +select perl_elog('explicit elog'); +NOTICE: explicit elog + perl_elog +----------- + +(1 row) + +create or replace function perl_warn(text) returns void language plperl as $$ + + my $msg = shift; + warn($msg); + +$$; +select perl_warn('implicit elog via warn'); +WARNING: implicit elog via warn at line 4. + perl_warn +----------- + +(1 row) + +-- test strict mode on/off +SET plperl.use_strict = true; +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global = 2; + return 'uses_global worked'; + +$$; +ERROR: Global symbol "$global" requires explicit package name (did you forget to declare "my $global"?) at line 3. +Global symbol "$other_global" requires explicit package name (did you forget to declare "my $other_global"?) at line 4. +CONTEXT: compilation of PL/Perl function "uses_global" +select uses_global(); +ERROR: function uses_global() does not exist +LINE 1: select uses_global(); + ^ +HINT: No function matches the given name and argument types. You might need to add explicit type casts. +SET plperl.use_strict = false; +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global=2; + return 'uses_global worked'; + +$$; +select uses_global(); + uses_global +-------------------- + uses_global worked +(1 row) + +-- make sure we don't choke on readonly values +do language plperl $$ elog(NOTICE, ${^TAINT}); $$; +NOTICE: 0 +-- test recovery after "die" +create or replace function just_die() returns void language plperl AS $$ +die "just die"; +$$; +select just_die(); +ERROR: just die at line 2. +CONTEXT: PL/Perl function "just_die" +create or replace function die_caller() returns int language plpgsql as $$ +BEGIN + BEGIN + PERFORM just_die(); + EXCEPTION WHEN OTHERS THEN + RAISE NOTICE 'caught die'; + END; + RETURN 1; +END; +$$; +select die_caller(); +NOTICE: caught die + die_caller +------------ + 1 +(1 row) + +create or replace function indirect_die_caller() returns int language plperl as $$ +my $prepared = spi_prepare('SELECT die_caller() AS fx'); +my $a = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +my $b = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +return $a + $b; +$$; +select indirect_die_caller(); +NOTICE: caught die +NOTICE: caught die + indirect_die_caller +--------------------- + 2 +(1 row) + +-- Test non-ASCII error messages +-- +-- Note: this test case is known to fail if the database encoding is +-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to +-- U+00A0 (no-break space) in those encodings. However, testing with +-- plain ASCII data would be rather useless, so we must live with that. +SET client_encoding TO UTF8; +create or replace function error_with_nbsp() returns void language plperl as $$ + elog(ERROR, "this message contains a no-break space"); +$$; +select error_with_nbsp(); +ERROR: this message contains a no-break space at line 2. +CONTEXT: PL/Perl function "error_with_nbsp" diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out new file mode 100644 index 0000000..133828e --- /dev/null +++ b/src/pl/plperl/expected/plperl_init.out @@ -0,0 +1,14 @@ +-- test plperl.on_plperl_init errors are fatal +-- This test tests setting on_plperl_init after loading plperl +LOAD 'plperl'; +SET SESSION plperl.on_plperl_init = ' system("/nonesuch"); '; +SHOW plperl.on_plperl_init; + plperl.on_plperl_init +------------------------ + system("/nonesuch"); +(1 row) + +DO $$ warn 42 $$ language plperl; +ERROR: 'system' trapped by operation mask at line 1. +CONTEXT: while executing plperl.on_plperl_init +PL/Perl anonymous code block diff --git a/src/pl/plperl/expected/plperl_lc.out b/src/pl/plperl/expected/plperl_lc.out new file mode 100644 index 0000000..4f8c08f --- /dev/null +++ b/src/pl/plperl/expected/plperl_lc.out @@ -0,0 +1,10 @@ +-- +-- Make sure strings are validated +-- Should fail for all encodings, as nul bytes are never permitted. +-- +CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$ + return "abcd\0efg"; +$$ LANGUAGE plperl; +SELECT perl_zerob(); +ERROR: invalid byte sequence for encoding "UTF8": 0x00 +CONTEXT: PL/Perl function "perl_zerob" diff --git a/src/pl/plperl/expected/plperl_lc_1.out b/src/pl/plperl/expected/plperl_lc_1.out new file mode 100644 index 0000000..022c3e2 --- /dev/null +++ b/src/pl/plperl/expected/plperl_lc_1.out @@ -0,0 +1,10 @@ +-- +-- Make sure strings are validated +-- Should fail for all encodings, as nul bytes are never permitted. +-- +CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$ + return "abcd\0efg"; +$$ LANGUAGE plperl; +SELECT perl_zerob(); +ERROR: invalid byte sequence for encoding "SQL_ASCII": 0x00 +CONTEXT: PL/Perl function "perl_zerob" diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out new file mode 100644 index 0000000..2be955f --- /dev/null +++ b/src/pl/plperl/expected/plperl_plperlu.out @@ -0,0 +1,91 @@ +-- test plperl/plperlu interaction +-- the language and call ordering of this test sequence is useful +CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$ + #die 'BANG!'; # causes server process to exit(2) + # alternative - causes server process to exit(255) + spi_exec_query("invalid sql statement"); +$$ language plperl; -- compile plperl code +CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$ + spi_exec_query("SELECT * FROM bar()"); + return 1; +$$ LANGUAGE plperlu; -- compile plperlu code +SELECT * FROM bar(); -- throws exception normally (running plperl) +ERROR: syntax error at or near "invalid" at line 4. +CONTEXT: PL/Perl function "bar" +SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu) +ERROR: syntax error at or near "invalid" at line 4. at line 2. +CONTEXT: PL/Perl function "foo" +-- test redefinition of specific SP switching languages +-- http://archives.postgresql.org/pgsql-bugs/2010-01/msg00116.php +-- plperl first +create or replace function foo(text) returns text language plperl as 'shift'; +select foo('hey'); + foo +----- + hey +(1 row) + +create or replace function foo(text) returns text language plperlu as 'shift'; +select foo('hey'); + foo +----- + hey +(1 row) + +create or replace function foo(text) returns text language plperl as 'shift'; +select foo('hey'); + foo +----- + hey +(1 row) + +-- plperlu first +create or replace function bar(text) returns text language plperlu as 'shift'; +select bar('hey'); + bar +----- + hey +(1 row) + +create or replace function bar(text) returns text language plperl as 'shift'; +select bar('hey'); + bar +----- + hey +(1 row) + +create or replace function bar(text) returns text language plperlu as 'shift'; +select bar('hey'); + bar +----- + hey +(1 row) + +-- +-- Make sure we can't use/require things in plperl +-- +CREATE OR REPLACE FUNCTION use_plperlu() RETURNS void LANGUAGE plperlu +AS $$ +use Errno; +$$; +CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl +AS $$ +use Errno; +$$; +ERROR: Unable to load Errno.pm into plperl at line 2. +BEGIN failed--compilation aborted at line 2. +CONTEXT: compilation of PL/Perl function "use_plperl" +-- make sure our overloaded require op gets restored/set correctly +select use_plperlu(); + use_plperlu +------------- + +(1 row) + +CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl +AS $$ +use Errno; +$$; +ERROR: Unable to load Errno.pm into plperl at line 2. +BEGIN failed--compilation aborted at line 2. +CONTEXT: compilation of PL/Perl function "use_plperl" diff --git a/src/pl/plperl/expected/plperl_setup.out b/src/pl/plperl/expected/plperl_setup.out new file mode 100644 index 0000000..a1a24df --- /dev/null +++ b/src/pl/plperl/expected/plperl_setup.out @@ -0,0 +1,69 @@ +-- +-- Install the plperl and plperlu extensions +-- +-- Before going ahead with the to-be-tested installations, verify that +-- a non-superuser is allowed to install plperl (but not plperlu) when +-- suitable permissions have been granted. +CREATE USER regress_user1; +CREATE USER regress_user2; +SET ROLE regress_user1; +CREATE EXTENSION plperl; -- fail +ERROR: permission denied to create extension "plperl" +HINT: Must have CREATE privilege on current database to create this extension. +CREATE EXTENSION plperlu; -- fail +ERROR: permission denied to create extension "plperlu" +HINT: Must be superuser to create this extension. +RESET ROLE; +DO $$ +begin + execute format('grant create on database %I to regress_user1', + current_database()); +end; +$$; +SET ROLE regress_user1; +CREATE EXTENSION plperl; +CREATE EXTENSION plperlu; -- fail +ERROR: permission denied to create extension "plperlu" +HINT: Must be superuser to create this extension. +CREATE FUNCTION foo1() returns int language plperl as '1;'; +SELECT foo1(); + foo1 +------ + 1 +(1 row) + +-- Must reconnect to avoid failure with non-MULTIPLICITY Perl interpreters +\c - +SET ROLE regress_user1; +-- Should be able to change privileges on the language +revoke all on language plperl from public; +SET ROLE regress_user2; +CREATE FUNCTION foo2() returns int language plperl as '2;'; -- fail +ERROR: permission denied for language plperl +SET ROLE regress_user1; +grant usage on language plperl to regress_user2; +SET ROLE regress_user2; +CREATE FUNCTION foo2() returns int language plperl as '2;'; +SELECT foo2(); + foo2 +------ + 2 +(1 row) + +SET ROLE regress_user1; +-- Should be able to drop the extension, but not the language per se +DROP LANGUAGE plperl CASCADE; +ERROR: cannot drop language plperl because extension plperl requires it +HINT: You can drop extension plperl instead. +DROP EXTENSION plperl CASCADE; +NOTICE: drop cascades to 2 other objects +DETAIL: drop cascades to function foo1() +drop cascades to function foo2() +-- Clean up +RESET ROLE; +DROP OWNED BY regress_user1; +DROP USER regress_user1; +DROP USER regress_user2; +-- Now install the versions that will be used by subsequent test scripts. +CREATE EXTENSION plperl; +CREATE EXTENSION plperlu; diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out new file mode 100644 index 0000000..464e220 --- /dev/null +++ b/src/pl/plperl/expected/plperl_shared.out @@ -0,0 +1,56 @@ +-- test plperl.on_plperl_init via the shared hash +-- (must be done before plperl is first used) +-- This test tests setting on_plperl_init before loading plperl +-- testing on_plperl_init gets run, and that it can alter %_SHARED +SET plperl.on_plperl_init = '$_SHARED{on_init} = 42'; +-- test the shared hash +create function setme(key text, val text) returns void language plperl as $$ + + my $key = shift; + my $val = shift; + $_SHARED{$key}= $val; + +$$; +create function getme(key text) returns text language plperl as $$ + + my $key = shift; + return $_SHARED{$key}; + +$$; +select setme('ourkey','ourval'); + setme +------- + +(1 row) + +select getme('ourkey'); + getme +-------- + ourval +(1 row) + +select getme('on_init'); + getme +------- + 42 +(1 row) + +-- verify that we can use $_SHARED in strict mode +create or replace function perl_shared() returns int as $$ +use strict; +my $val = $_SHARED{'stuff'}; +$_SHARED{'stuff'} = '1'; +return $val; +$$ language plperl; +select perl_shared(); + perl_shared +------------- + +(1 row) + +select perl_shared(); + perl_shared +------------- + 1 +(1 row) + diff --git a/src/pl/plperl/expected/plperl_transaction.out b/src/pl/plperl/expected/plperl_transaction.out new file mode 100644 index 0000000..7ca0ef3 --- /dev/null +++ b/src/pl/plperl/expected/plperl_transaction.out @@ -0,0 +1,196 @@ +CREATE TABLE test1 (a int, b text); +CREATE PROCEDURE transaction_test1() +LANGUAGE plperl +AS $$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; +CALL transaction_test1(); +SELECT * FROM test1; + a | b +---+--- + 0 | + 2 | + 4 | + 6 | + 8 | +(5 rows) + +TRUNCATE test1; +DO +LANGUAGE plperl +$$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; +SELECT * FROM test1; + a | b +---+--- + 0 | + 2 | + 4 | + 6 | + 8 | +(5 rows) + +TRUNCATE test1; +-- not allowed in a function +CREATE FUNCTION transaction_test2() RETURNS int +LANGUAGE plperl +AS $$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +return 1; +$$; +SELECT transaction_test2(); +ERROR: invalid transaction termination at line 5. +CONTEXT: PL/Perl function "transaction_test2" +SELECT * FROM test1; + a | b +---+--- +(0 rows) + +-- also not allowed if procedure is called from a function +CREATE FUNCTION transaction_test3() RETURNS int +LANGUAGE plperl +AS $$ +spi_exec_query("CALL transaction_test1()"); +return 1; +$$; +SELECT transaction_test3(); +ERROR: invalid transaction termination at line 5. at line 2. +CONTEXT: PL/Perl function "transaction_test3" +SELECT * FROM test1; + a | b +---+--- +(0 rows) + +-- DO block inside function +CREATE FUNCTION transaction_test4() RETURNS int +LANGUAGE plperl +AS $$ +spi_exec_query('DO LANGUAGE plperl $x$ spi_commit(); $x$'); +return 1; +$$; +SELECT transaction_test4(); +ERROR: invalid transaction termination at line 1. at line 2. +CONTEXT: PL/Perl function "transaction_test4" +-- commit inside cursor loop +CREATE TABLE test2 (x int); +INSERT INTO test2 VALUES (0), (1), (2), (3), (4); +TRUNCATE test1; +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + spi_commit(); +} +$$; +SELECT * FROM test1; + a | b +---+--- + 0 | + 1 | + 2 | + 3 | + 4 | +(5 rows) + +-- check that this doesn't leak a holdable portal +SELECT * FROM pg_cursors; + name | statement | is_holdable | is_binary | is_scrollable | creation_time +------+-----------+-------------+-----------+---------------+--------------- +(0 rows) + +-- error in cursor loop with commit +TRUNCATE test1; +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (12/(" . $row->{x} . "-2))"); + spi_commit(); +} +$$; +ERROR: division by zero at line 5. +CONTEXT: PL/Perl anonymous code block +SELECT * FROM test1; + a | b +-----+--- + -6 | + -12 | +(2 rows) + +SELECT * FROM pg_cursors; + name | statement | is_holdable | is_binary | is_scrollable | creation_time +------+-----------+-------------+-----------+---------------+--------------- +(0 rows) + +-- rollback inside cursor loop +TRUNCATE test1; +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + spi_rollback(); +} +$$; +SELECT * FROM test1; + a | b +---+--- +(0 rows) + +SELECT * FROM pg_cursors; + name | statement | is_holdable | is_binary | is_scrollable | creation_time +------+-----------+-------------+-----------+---------------+--------------- +(0 rows) + +-- first commit then rollback inside cursor loop +TRUNCATE test1; +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + if ($row->{x} % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; +SELECT * FROM test1; + a | b +---+--- + 0 | + 2 | + 4 | +(3 rows) + +SELECT * FROM pg_cursors; + name | statement | is_holdable | is_binary | is_scrollable | creation_time +------+-----------+-------------+-----------+---------------+--------------- +(0 rows) + +DROP TABLE test1; +DROP TABLE test2; diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out new file mode 100644 index 0000000..d4879e2 --- /dev/null +++ b/src/pl/plperl/expected/plperl_trigger.out @@ -0,0 +1,392 @@ +-- test plperl triggers +CREATE TYPE rowcomp as (i int); +CREATE TYPE rowcompnest as (rfoo rowcomp); +CREATE TABLE trigger_test ( + i int, + v varchar, + foo rowcompnest +); +CREATE TABLE trigger_test_generated ( + i int, + j int GENERATED ALWAYS AS (i * 2) STORED +); +CREATE OR REPLACE FUNCTION trigger_data() RETURNS trigger LANGUAGE plperl AS $$ + + # make sure keys are sorted for consistent results - perl no longer + # hashes in repeatable fashion across runs + + sub str { + my $val = shift; + + if (!defined $val) + { + return 'NULL'; + } + elsif (ref $val eq 'HASH') + { + my $str = ''; + foreach my $rowkey (sort keys %$val) + { + $str .= ", " if $str; + my $rowval = str($val->{$rowkey}); + $str .= "'$rowkey' => $rowval"; + } + return '{'. $str .'}'; + } + elsif (ref $val eq 'ARRAY') + { + my $str = ''; + for my $argval (@$val) + { + $str .= ", " if $str; + $str .= str($argval); + } + return '['. $str .']'; + } + else + { + return "'$val'"; + } + } + + foreach my $key (sort keys %$_TD) + { + + my $val = $_TD->{$key}; + + # relid is variable, so we can not use it repeatably + $val = "bogus:12345" if $key eq 'relid'; + + elog(NOTICE, "\$_TD->\{$key\} = ". str($val)); + } + return undef; # allow statement to proceed; +$$; +CREATE TRIGGER show_trigger_data_trig +BEFORE INSERT OR UPDATE OR DELETE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); +insert into trigger_test values(1,'insert', '("(1)")'); +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['23', 'skidoo'] +NOTICE: $_TD->{event} = 'INSERT' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test' +NOTICE: $_TD->{table_name} = 'trigger_test' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +update trigger_test set v = 'update' where i = 1; +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['23', 'skidoo'] +NOTICE: $_TD->{event} = 'UPDATE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'} +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test' +NOTICE: $_TD->{table_name} = 'trigger_test' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +delete from trigger_test; +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['23', 'skidoo'] +NOTICE: $_TD->{event} = 'DELETE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test' +NOTICE: $_TD->{table_name} = 'trigger_test' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +DROP TRIGGER show_trigger_data_trig on trigger_test; +CREATE TRIGGER show_trigger_data_trig_before +BEFORE INSERT OR UPDATE OR DELETE ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE trigger_data(); +CREATE TRIGGER show_trigger_data_trig_after +AFTER INSERT OR UPDATE OR DELETE ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE trigger_data(); +insert into trigger_test_generated (i) values (1); +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'INSERT' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_before' +NOTICE: $_TD->{new} = {'i' => '1'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'INSERT' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_after' +NOTICE: $_TD->{new} = {'i' => '1', 'j' => '2'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'AFTER' +update trigger_test_generated set i = 11 where i = 1; +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'UPDATE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_before' +NOTICE: $_TD->{new} = {'i' => '11'} +NOTICE: $_TD->{old} = {'i' => '1', 'j' => '2'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'UPDATE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_after' +NOTICE: $_TD->{new} = {'i' => '11', 'j' => '22'} +NOTICE: $_TD->{old} = {'i' => '1', 'j' => '2'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'AFTER' +delete from trigger_test_generated; +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'DELETE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_before' +NOTICE: $_TD->{old} = {'i' => '11', 'j' => '22'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'BEFORE' +NOTICE: $_TD->{argc} = '0' +NOTICE: $_TD->{event} = 'DELETE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig_after' +NOTICE: $_TD->{old} = {'i' => '11', 'j' => '22'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_generated' +NOTICE: $_TD->{table_name} = 'trigger_test_generated' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'AFTER' +DROP TRIGGER show_trigger_data_trig_before ON trigger_test_generated; +DROP TRIGGER show_trigger_data_trig_after ON trigger_test_generated; +insert into trigger_test values(1,'insert', '("(1)")'); +CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test; +CREATE TRIGGER show_trigger_data_trig +INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view +FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view'); +insert into trigger_test_view values(2,'insert', '("(2)")'); +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['24', 'skidoo view'] +NOTICE: $_TD->{event} = 'INSERT' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '2'}}, 'i' => '2', 'v' => 'insert'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_view' +NOTICE: $_TD->{table_name} = 'trigger_test_view' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'INSTEAD OF' +update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1; +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['24', 'skidoo view'] +NOTICE: $_TD->{event} = 'UPDATE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '3'}}, 'i' => '1', 'v' => 'update'} +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_view' +NOTICE: $_TD->{table_name} = 'trigger_test_view' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'INSTEAD OF' +delete from trigger_test_view; +NOTICE: $_TD->{argc} = '2' +NOTICE: $_TD->{args} = ['24', 'skidoo view'] +NOTICE: $_TD->{event} = 'DELETE' +NOTICE: $_TD->{level} = 'ROW' +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +NOTICE: $_TD->{relid} = 'bogus:12345' +NOTICE: $_TD->{relname} = 'trigger_test_view' +NOTICE: $_TD->{table_name} = 'trigger_test_view' +NOTICE: $_TD->{table_schema} = 'public' +NOTICE: $_TD->{when} = 'INSTEAD OF' +DROP VIEW trigger_test_view; +delete from trigger_test; +DROP FUNCTION trigger_data(); +CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$ + + if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0)) + { + return "SKIP"; # Skip INSERT/UPDATE command + } + elsif ($_TD->{new}{v} ne "immortal") + { + $_TD->{new}{v} .= "(modified by trigger)"; + $_TD->{new}{foo}{rfoo}{i}++; + return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command + } + else + { + return; # Proceed INSERT/UPDATE command + } +$$ LANGUAGE plperl; +CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE "valid_id"(); +INSERT INTO trigger_test (i, v, foo) VALUES (1,'first line', '("(1)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (2,'second line', '("(2)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (3,'third line', '("(3)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (4,'immortal', '("(4)")'); +INSERT INTO trigger_test (i, v) VALUES (101,'bad id'); +SELECT * FROM trigger_test; + i | v | foo +---+----------------------------------+--------- + 1 | first line(modified by trigger) | ("(2)") + 2 | second line(modified by trigger) | ("(3)") + 3 | third line(modified by trigger) | ("(4)") + 4 | immortal | ("(4)") +(4 rows) + +UPDATE trigger_test SET i = 5 where i=3; +UPDATE trigger_test SET i = 100 where i=1; +SELECT * FROM trigger_test; + i | v | foo +---+------------------------------------------------------+--------- + 1 | first line(modified by trigger) | ("(2)") + 2 | second line(modified by trigger) | ("(3)") + 4 | immortal | ("(4)") + 5 | third line(modified by trigger)(modified by trigger) | ("(5)") +(4 rows) + +DROP TRIGGER "test_valid_id_trig" ON trigger_test; +CREATE OR REPLACE FUNCTION trigger_recurse() RETURNS trigger AS $$ + use strict; + + if ($_TD->{new}{i} == 10000) + { + spi_exec_query("insert into trigger_test (i, v) values (20000, 'child');"); + + if ($_TD->{new}{i} != 10000) + { + die "recursive trigger modified: ". $_TD->{new}{i}; + } + } + return; +$$ LANGUAGE plperl; +CREATE TRIGGER "test_trigger_recurse" BEFORE INSERT ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE "trigger_recurse"(); +INSERT INTO trigger_test (i, v) values (10000, 'top'); +SELECT * FROM trigger_test; + i | v | foo +-------+------------------------------------------------------+--------- + 1 | first line(modified by trigger) | ("(2)") + 2 | second line(modified by trigger) | ("(3)") + 4 | immortal | ("(4)") + 5 | third line(modified by trigger)(modified by trigger) | ("(5)") + 20000 | child | + 10000 | top | +(6 rows) + +CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$ + if ($_TD->{old}{v} eq $_TD->{args}[0]) + { + return "SKIP"; # Skip DELETE command + } + else + { + return; # Proceed DELETE command + }; +$$ LANGUAGE plperl; +CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE immortal('immortal'); +DELETE FROM trigger_test; +SELECT * FROM trigger_test; + i | v | foo +---+----------+--------- + 4 | immortal | ("(4)") +(1 row) + +CREATE FUNCTION direct_trigger() RETURNS trigger AS $$ + return; +$$ LANGUAGE plperl; +SELECT direct_trigger(); +ERROR: trigger functions can only be called as triggers +CONTEXT: compilation of PL/Perl function "direct_trigger" +-- check that SQL run in trigger code can see transition tables +CREATE TABLE transition_table_test (id int, name text); +INSERT INTO transition_table_test VALUES (1, 'a'); +CREATE FUNCTION transition_table_test_f() RETURNS trigger LANGUAGE plperl AS +$$ + my $cursor = spi_query("SELECT * FROM old_table"); + my $row = spi_fetchrow($cursor); + defined($row) || die "expected a row"; + elog(INFO, "old: " . $row->{id} . " -> " . $row->{name}); + my $row = spi_fetchrow($cursor); + !defined($row) || die "expected no more rows"; + + my $cursor = spi_query("SELECT * FROM new_table"); + my $row = spi_fetchrow($cursor); + defined($row) || die "expected a row"; + elog(INFO, "new: " . $row->{id} . " -> " . $row->{name}); + my $row = spi_fetchrow($cursor); + !defined($row) || die "expected no more rows"; + + return undef; +$$; +CREATE TRIGGER a_t AFTER UPDATE ON transition_table_test + REFERENCING OLD TABLE AS old_table NEW TABLE AS new_table + FOR EACH STATEMENT EXECUTE PROCEDURE transition_table_test_f(); +UPDATE transition_table_test SET name = 'b'; +INFO: old: 1 -> a +INFO: new: 1 -> b +DROP TABLE transition_table_test; +DROP FUNCTION transition_table_test_f(); +-- test plperl command triggers +create or replace function perlsnitch() returns event_trigger language plperl as $$ + elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " "); +$$; +create event trigger perl_a_snitch on ddl_command_start + execute procedure perlsnitch(); +create event trigger perl_b_snitch on ddl_command_end + execute procedure perlsnitch(); +create or replace function foobar() returns int language sql as $$select 1;$$; +NOTICE: perlsnitch: ddl_command_start CREATE FUNCTION +NOTICE: perlsnitch: ddl_command_end CREATE FUNCTION +alter function foobar() cost 77; +NOTICE: perlsnitch: ddl_command_start ALTER FUNCTION +NOTICE: perlsnitch: ddl_command_end ALTER FUNCTION +drop function foobar(); +NOTICE: perlsnitch: ddl_command_start DROP FUNCTION +NOTICE: perlsnitch: ddl_command_end DROP FUNCTION +create table foo(); +NOTICE: perlsnitch: ddl_command_start CREATE TABLE +NOTICE: perlsnitch: ddl_command_end CREATE TABLE +drop table foo; +NOTICE: perlsnitch: ddl_command_start DROP TABLE +NOTICE: perlsnitch: ddl_command_end DROP TABLE +drop event trigger perl_a_snitch; +drop event trigger perl_b_snitch; +-- dealing with generated columns +CREATE FUNCTION generated_test_func1() RETURNS trigger +LANGUAGE plperl +AS $$ +$_TD->{new}{j} = 5; # not allowed +return 'MODIFY'; +$$; +CREATE TRIGGER generated_test_trigger1 BEFORE INSERT ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE generated_test_func1(); +TRUNCATE trigger_test_generated; +INSERT INTO trigger_test_generated (i) VALUES (1); +ERROR: cannot set generated column "j" +CONTEXT: PL/Perl function "generated_test_func1" +SELECT * FROM trigger_test_generated; + i | j +---+--- +(0 rows) + diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out new file mode 100644 index 0000000..698a8a1 --- /dev/null +++ b/src/pl/plperl/expected/plperl_util.out @@ -0,0 +1,198 @@ +-- 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 quote_nullable($_).": ". (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 + ' ', # only space + ''; # empty string + 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 + ' ': not number + '': not number +(11 rows) + +-- test encode_typed_literal +create type perl_foo as (a integer, b text[]); +create type perl_bar as (c perl_foo[]); +create domain perl_foo_pos as perl_foo check((value).a > 0); +create or replace function perl_encode_typed_literal() returns setof text language plperl as $$ + return_next encode_typed_literal(undef, 'text'); + return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]'); + return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo'); + return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar'); + return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos'); +$$; +select perl_encode_typed_literal(); + perl_encode_typed_literal +----------------------------------------------- + + {{1,2,3},{3,2,1},{1,3,2}} + (1,"{PL,/,Perl}") + ("{""(9,{PostgreSQL})"",""(1,{Postgres})""}") + (1,"{PL,/,Perl}") +(5 rows) + +create or replace function perl_encode_typed_literal() returns setof text language plperl as $$ + return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos'); +$$; +select perl_encode_typed_literal(); -- fail +ERROR: value for domain perl_foo_pos violates check constraint "perl_foo_pos_check" +CONTEXT: PL/Perl function "perl_encode_typed_literal" diff --git a/src/pl/plperl/expected/plperlu.out b/src/pl/plperl/expected/plperlu.out new file mode 100644 index 0000000..a3edb38 --- /dev/null +++ b/src/pl/plperl/expected/plperlu.out @@ -0,0 +1,15 @@ +-- Use ONLY plperlu tests here. For plperl/plerlu combined tests +-- see plperl_plperlu.sql +-- This test tests setting on_plperlu_init after loading plperl +LOAD 'plperl'; +-- Test plperl.on_plperlu_init gets run +SET plperl.on_plperlu_init = '$_SHARED{init} = 42'; +DO $$ warn $_SHARED{init} $$ language plperlu; +WARNING: 42 at line 1. +-- +-- Test compilation of unicode regex - regardless of locale. +-- This code fails in plain plperl in a non-UTF8 database. +-- +CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$ + return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley +$$ LANGUAGE plperlu; diff --git a/src/pl/plperl/nls.mk b/src/pl/plperl/nls.mk new file mode 100644 index 0000000..5a190f2 --- /dev/null +++ b/src/pl/plperl/nls.mk @@ -0,0 +1,6 @@ +# src/pl/plperl/nls.mk +CATALOG_NAME = plperl +AVAIL_LANGUAGES = cs de es fr it ja ko pl pt_BR ro ru sv tr uk vi zh_CN +GETTEXT_FILES = plperl.c SPI.c +GETTEXT_TRIGGERS = $(BACKEND_COMMON_GETTEXT_TRIGGERS) +GETTEXT_FLAGS = $(BACKEND_COMMON_GETTEXT_FLAGS) diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl new file mode 100644 index 0000000..ee1b9bf --- /dev/null +++ b/src/pl/plperl/plc_perlboot.pl @@ -0,0 +1,126 @@ +# src/pl/plperl/plc_perlboot.pl + +use strict; +use warnings; + +use 5.008001; +use vars qw(%_SHARED $_TD); + +PostgreSQL::InServer::Util::bootstrap(); + +# globals + +sub ::is_array_ref +{ + return ref($_[0]) =~ m/^(?:PostgreSQL::InServer::)?ARRAY$/; +} + +sub ::encode_array_literal +{ + my ($arg, $delim) = @_; + return $arg unless (::is_array_ref($arg)); + $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) unless ::is_array_ref($arg); + my $res = join ", ", + map { (ref $_) ? ::encode_array_constructor($_) : ::quote_nullable($_) } + @$arg; + return "ARRAY[$res]"; +} + +{ +#<<< protect next line from perltidy so perlcritic annotation works + package PostgreSQL::InServer; ## no critic (RequireFilenameMatchesPackage) +#>>> + use strict; + use warnings; + + sub plperl_warn + { + (my $msg = shift) =~ s/\(eval \d+\) //g; + chomp $msg; + &::elog(&::WARNING, $msg); + return; + } + $SIG{__WARN__} = \&plperl_warn; + + sub plperl_die + { + (my $msg = shift) =~ s/\(eval \d+\) //g; + die $msg; + } + $SIG{__DIE__} = \&plperl_die; + + sub mkfuncsrc + { + my ($name, $imports, $prolog, $src) = @_; + + my $BEGIN = join "\n", map { + my $names = $imports->{$_} || []; + "$_->import(qw(@$names));" + } sort keys %$imports; + $BEGIN &&= "BEGIN { $BEGIN }"; + + return qq[ package main; sub { $BEGIN $prolog $src } ]; + } + + sub mkfunc + { + ## no critic (ProhibitNoStrict, ProhibitStringyEval); + no strict; # default to no strict for the eval + no warnings; # default to no warnings for the eval + my $ret = eval(mkfuncsrc(@_)); + $@ =~ s/\(eval \d+\) //g if $@; + return $ret; + ## use critic + } + + 1; +} + +{ + + package PostgreSQL::InServer::ARRAY; + use strict; + use warnings; + + use overload + '""' => \&to_str, + '@{}' => \&to_arr; + + sub to_str + { + my $self = shift; + return ::encode_typed_literal($self->{'array'}, $self->{'typeoid'}); + } + + sub to_arr + { + return shift->{'array'}; + } + + 1; +} diff --git a/src/pl/plperl/plc_trusted.pl b/src/pl/plperl/plc_trusted.pl new file mode 100644 index 0000000..dea3727 --- /dev/null +++ b/src/pl/plperl/plc_trusted.pl @@ -0,0 +1,29 @@ +# src/pl/plperl/plc_trusted.pl + +#<<< protect next line from perltidy so perlcritic annotation works +package PostgreSQL::InServer::safe; ## no critic (RequireFilenameMatchesPackage) +#>>> + +# Load widely useful pragmas into plperl to make them available. +# +# SECURITY RISKS: +# +# Since these modules are free to compile unsafe opcodes they must +# be trusted to now allow any code containing unsafe opcodes to be abused. +# That's much harder than it sounds. +# +# Be aware that perl provides a wide variety of ways to subvert +# pre-compiled code. For some examples, see this presentation: +# http://www.slideshare.net/cdman83/barely-legal-xxx-perl-presentation +# +# If in ANY doubt about a module, or ANY of the modules down the chain of +# dependencies it loads, then DO NOT add it to this list. +# +# To check if any of these modules use "unsafe" opcodes you can compile +# plperl with the PLPERL_ENABLE_OPMASK_EARLY macro defined. See plperl.c + +require strict; +require Carp; +require Carp::Heavy; +require warnings; +require feature if $] >= 5.010000; diff --git a/src/pl/plperl/plperl--1.0.sql b/src/pl/plperl/plperl--1.0.sql new file mode 100644 index 0000000..5ff31e7 --- /dev/null +++ b/src/pl/plperl/plperl--1.0.sql @@ -0,0 +1,20 @@ +/* src/pl/plperl/plperl--1.0.sql */ + +CREATE FUNCTION plperl_call_handler() RETURNS language_handler + LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE FUNCTION plperl_inline_handler(internal) RETURNS void + STRICT LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE FUNCTION plperl_validator(oid) RETURNS void + STRICT LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE TRUSTED LANGUAGE plperl + HANDLER plperl_call_handler + INLINE plperl_inline_handler + VALIDATOR plperl_validator; + +-- The language object, but not the functions, can be owned by a non-superuser. +ALTER LANGUAGE plperl OWNER TO @extowner@; + +COMMENT ON LANGUAGE plperl IS 'PL/Perl procedural language'; diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c new file mode 100644 index 0000000..5fdf303 --- /dev/null +++ b/src/pl/plperl/plperl.c @@ -0,0 +1,4208 @@ +/********************************************************************** + * plperl.c - perl as a procedural language for PostgreSQL + * + * src/pl/plperl/plperl.c + * + **********************************************************************/ + +#include "postgres.h" + +/* system stuff */ +#include <ctype.h> +#include <fcntl.h> +#include <limits.h> +#include <unistd.h> + +/* postgreSQL stuff */ +#include "access/htup_details.h" +#include "access/xact.h" +#include "catalog/pg_language.h" +#include "catalog/pg_proc.h" +#include "catalog/pg_type.h" +#include "commands/event_trigger.h" +#include "commands/trigger.h" +#include "executor/spi.h" +#include "funcapi.h" +#include "mb/pg_wchar.h" +#include "miscadmin.h" +#include "nodes/makefuncs.h" +#include "parser/parse_type.h" +#include "storage/ipc.h" +#include "tcop/tcopprot.h" +#include "utils/builtins.h" +#include "utils/fmgroids.h" +#include "utils/guc.h" +#include "utils/hsearch.h" +#include "utils/lsyscache.h" +#include "utils/memutils.h" +#include "utils/rel.h" +#include "utils/syscache.h" +#include "utils/typcache.h" + +/* define our text domain for translations */ +#undef TEXTDOMAIN +#define TEXTDOMAIN PG_TEXTDOMAIN("plperl") + +/* perl stuff */ +/* string literal macros defining chunks of perl code */ +#include "perlchunks.h" +#include "plperl.h" +#include "plperl_helpers.h" +/* defines PLPERL_SET_OPMASK */ +#include "plperl_opmask.h" + +EXTERN_C void boot_DynaLoader(pTHX_ CV *cv); +EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv); +EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv); + +PG_MODULE_MAGIC; + +/********************************************************************** + * Information associated with a Perl interpreter. We have one interpreter + * that is used for all plperlu (untrusted) functions. For plperl (trusted) + * functions, there is a separate interpreter for each effective SQL userid. + * (This is needed to ensure that an unprivileged user can't inject Perl code + * that'll be executed with the privileges of some other SQL user.) + * + * The plperl_interp_desc structs are kept in a Postgres hash table indexed + * by userid OID, with OID 0 used for the single untrusted interpreter. + * Once created, an interpreter is kept for the life of the process. + * + * We start out by creating a "held" interpreter, which we initialize + * only as far as we can do without deciding if it will be trusted or + * untrusted. Later, when we first need to run a plperl or plperlu + * function, we complete the initialization appropriately and move the + * PerlInterpreter pointer into the plperl_interp_hash hashtable. If after + * that we need more interpreters, we create them as needed if we can, or + * fail if the Perl build doesn't support multiple interpreters. + * + * The reason for all the dancing about with a held interpreter is to make + * it possible for people to preload a lot of Perl code at postmaster startup + * (using plperl.on_init) and then use that code in backends. Of course this + * will only work for the first interpreter created in any backend, but it's + * still useful with that restriction. + **********************************************************************/ +typedef struct plperl_interp_desc +{ + Oid user_id; /* Hash key (must be first!) */ + PerlInterpreter *interp; /* The interpreter */ + HTAB *query_hash; /* plperl_query_entry structs */ +} plperl_interp_desc; + + +/********************************************************************** + * The information we cache about loaded procedures + * + * The fn_refcount field counts the struct's reference from the hash table + * shown below, plus one reference for each function call level that is using + * the struct. We can release the struct, and the associated Perl sub, when + * the fn_refcount goes to zero. Releasing the struct itself is done by + * deleting the fn_cxt, which also gets rid of all subsidiary data. + **********************************************************************/ +typedef struct plperl_proc_desc +{ + char *proname; /* user name of procedure */ + MemoryContext fn_cxt; /* memory context for this procedure */ + unsigned long fn_refcount; /* number of active references */ + TransactionId fn_xmin; /* xmin/TID of procedure's pg_proc tuple */ + ItemPointerData fn_tid; + SV *reference; /* CODE reference for Perl sub */ + plperl_interp_desc *interp; /* interpreter it's created in */ + bool fn_readonly; /* is function readonly (not volatile)? */ + Oid lang_oid; + List *trftypes; + bool lanpltrusted; /* is it plperl, rather than plperlu? */ + bool fn_retistuple; /* true, if function returns tuple */ + bool fn_retisset; /* true, if function returns set */ + bool fn_retisarray; /* true if function returns array */ + /* Conversion info for function's result type: */ + Oid result_oid; /* Oid of result type */ + FmgrInfo result_in_func; /* I/O function and arg for result type */ + Oid result_typioparam; + /* Per-argument info for function's argument types: */ + int nargs; + FmgrInfo *arg_out_func; /* output fns for arg types */ + bool *arg_is_rowtype; /* is each arg composite? */ + Oid *arg_arraytype; /* InvalidOid if not an array */ +} plperl_proc_desc; + +#define increment_prodesc_refcount(prodesc) \ + ((prodesc)->fn_refcount++) +#define decrement_prodesc_refcount(prodesc) \ + do { \ + Assert((prodesc)->fn_refcount > 0); \ + if (--((prodesc)->fn_refcount) == 0) \ + free_plperl_function(prodesc); \ + } while(0) + +/********************************************************************** + * For speedy lookup, we maintain a hash table mapping from + * function OID + trigger flag + user OID to plperl_proc_desc pointers. + * The reason the plperl_proc_desc struct isn't directly part of the hash + * entry is to simplify recovery from errors during compile_plperl_function. + * + * Note: if the same function is called by multiple userIDs within a session, + * there will be a separate plperl_proc_desc entry for each userID in the case + * of plperl functions, but only one entry for plperlu functions, because we + * set user_id = 0 for that case. If the user redeclares the same function + * from plperl to plperlu or vice versa, there might be multiple + * plperl_proc_ptr entries in the hashtable, but only one is valid. + **********************************************************************/ +typedef struct plperl_proc_key +{ + Oid proc_id; /* Function OID */ + + /* + * is_trigger is really a bool, but declare as Oid to ensure this struct + * contains no padding + */ + Oid is_trigger; /* is it a trigger function? */ + Oid user_id; /* User calling the function, or 0 */ +} plperl_proc_key; + +typedef struct plperl_proc_ptr +{ + plperl_proc_key proc_key; /* Hash key (must be first!) */ + plperl_proc_desc *proc_ptr; +} plperl_proc_ptr; + +/* + * The information we cache for the duration of a single call to a + * function. + */ +typedef struct plperl_call_data +{ + plperl_proc_desc *prodesc; + FunctionCallInfo fcinfo; + /* remaining fields are used only in a function returning set: */ + Tuplestorestate *tuple_store; + TupleDesc ret_tdesc; + Oid cdomain_oid; /* 0 unless returning domain-over-composite */ + void *cdomain_info; + MemoryContext tmp_cxt; +} plperl_call_data; + +/********************************************************************** + * The information we cache about prepared and saved plans + **********************************************************************/ +typedef struct plperl_query_desc +{ + char qname[24]; + MemoryContext plan_cxt; /* context holding this struct */ + SPIPlanPtr plan; + int nargs; + Oid *argtypes; + FmgrInfo *arginfuncs; + Oid *argtypioparams; +} plperl_query_desc; + +/* hash table entry for query desc */ + +typedef struct plperl_query_entry +{ + char query_name[NAMEDATALEN]; + plperl_query_desc *query_data; +} plperl_query_entry; + +/********************************************************************** + * Information for PostgreSQL - Perl array conversion. + **********************************************************************/ +typedef struct plperl_array_info +{ + int ndims; + bool elem_is_rowtype; /* 't' if element type is a rowtype */ + Datum *elements; + bool *nulls; + int *nelems; + FmgrInfo proc; + FmgrInfo transform_proc; +} plperl_array_info; + +/********************************************************************** + * Global data + **********************************************************************/ + +static HTAB *plperl_interp_hash = NULL; +static HTAB *plperl_proc_hash = NULL; +static plperl_interp_desc *plperl_active_interp = NULL; + +/* If we have an unassigned "held" interpreter, it's stored here */ +static PerlInterpreter *plperl_held_interp = NULL; + +/* GUC variables */ +static bool plperl_use_strict = false; +static char *plperl_on_init = NULL; +static char *plperl_on_plperl_init = NULL; +static char *plperl_on_plperlu_init = NULL; + +static bool plperl_ending = false; +static OP *(*pp_require_orig) (pTHX) = NULL; +static char plperl_opmask[MAXO]; + +/* this is saved and restored by plperl_call_handler */ +static plperl_call_data *current_call_data = NULL; + +/********************************************************************** + * Forward declarations + **********************************************************************/ +void _PG_init(void); + +static PerlInterpreter *plperl_init_interp(void); +static void plperl_destroy_interp(PerlInterpreter **); +static void plperl_fini(int code, Datum arg); +static void set_interp_require(bool trusted); + +static Datum plperl_func_handler(PG_FUNCTION_ARGS); +static Datum plperl_trigger_handler(PG_FUNCTION_ARGS); +static void plperl_event_trigger_handler(PG_FUNCTION_ARGS); + +static void free_plperl_function(plperl_proc_desc *prodesc); + +static plperl_proc_desc *compile_plperl_function(Oid fn_oid, + bool is_trigger, + bool is_event_trigger); + +static SV *plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc, bool include_generated); +static SV *plperl_hash_from_datum(Datum attr); +static SV *plperl_ref_from_pg_array(Datum arg, Oid typid); +static SV *split_array(plperl_array_info *info, int first, int last, int nest); +static SV *make_array_ref(plperl_array_info *info, int first, int last); +static SV *get_perl_array_ref(SV *sv); +static Datum plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, + FunctionCallInfo fcinfo, + FmgrInfo *finfo, Oid typioparam, + bool *isnull); +static void _sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam); +static Datum plperl_array_to_datum(SV *src, Oid typid, int32 typmod); +static void array_to_datum_internal(AV *av, ArrayBuildState *astate, + int *ndims, int *dims, int cur_depth, + Oid arraytypid, Oid elemtypid, int32 typmod, + FmgrInfo *finfo, Oid typioparam); +static Datum plperl_hash_to_datum(SV *src, TupleDesc td); + +static void plperl_init_shared_libs(pTHX); +static void plperl_trusted_init(void); +static void plperl_untrusted_init(void); +static HV *plperl_spi_execute_fetch_result(SPITupleTable *, uint64, int); +static void plperl_return_next_internal(SV *sv); +static char *hek2cstr(HE *he); +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, const 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); +static OP *pp_require_safe(pTHX); +static void activate_interpreter(plperl_interp_desc *interp_desc); + +#ifdef WIN32 +static char *setlocale_perl(int category, char *locale); +#endif + +/* + * Decrement the refcount of the given SV within the active Perl interpreter + * + * This is handy because it reloads the active-interpreter pointer, saving + * some notation in callers that switch the active interpreter. + */ +static inline void +SvREFCNT_dec_current(SV *sv) +{ + dTHX; + + SvREFCNT_dec(sv); +} + +/* + * convert a HE (hash entry) key to a cstr in the current database encoding + */ +static char * +hek2cstr(HE *he) +{ + dTHX; + char *ret; + SV *sv; + + /* + * HeSVKEY_force will return a temporary mortal SV*, so we need to make + * sure to free it with ENTER/SAVE/FREE/LEAVE + */ + ENTER; + SAVETMPS; + + /*------------------------- + * Unfortunately, while HeUTF8 is true for most things > 256, for values + * 128..255 it's not, but perl will treat them as unicode code points if + * the utf8 flag is not set ( see The "Unicode Bug" in perldoc perlunicode + * for more) + * + * So if we did the expected: + * if (HeUTF8(he)) + * utf_u2e(key...); + * else // must be ascii + * return HePV(he); + * we won't match columns with codepoints from 128..255 + * + * For a more concrete example given a column with the name of the unicode + * codepoint U+00ae (registered sign) and a UTF8 database and the perl + * return_next { "\N{U+00ae}=>'text } would always fail as heUTF8 returns + * 0 and HePV() would give us a char * with 1 byte contains the decimal + * value 174 + * + * Perl has the brains to know when it should utf8 encode 174 properly, so + * here we force it into an SV so that perl will figure it out and do the + * right thing + *------------------------- + */ + + sv = HeSVKEY_force(he); + if (HeUTF8(he)) + SvUTF8_on(sv); + ret = sv2cstr(sv); + + /* free sv */ + FREETMPS; + LEAVE; + + return ret; +} + + +/* + * _PG_init() - library load-time initialization + * + * DO NOT make this static nor change its name! + */ +void +_PG_init(void) +{ + /* + * Be sure we do initialization only once. + * + * If initialization fails due to, e.g., plperl_init_interp() throwing an + * exception, then we'll return here on the next usage and the user will + * get a rather cryptic: ERROR: attempt to redefine parameter + * "plperl.use_strict" + */ + static bool inited = false; + HASHCTL hash_ctl; + + if (inited) + return; + + /* + * Support localized messages. + */ + pg_bindtextdomain(TEXTDOMAIN); + + /* + * Initialize plperl's GUCs. + */ + DefineCustomBoolVariable("plperl.use_strict", + gettext_noop("If true, trusted and untrusted Perl code will be compiled in strict mode."), + NULL, + &plperl_use_strict, + false, + PGC_USERSET, 0, + NULL, NULL, NULL); + + /* + * plperl.on_init is marked PGC_SIGHUP to support the idea that it might + * be executed in the postmaster (if plperl is loaded into the postmaster + * via shared_preload_libraries). This isn't really right either way, + * though. + */ + DefineCustomStringVariable("plperl.on_init", + gettext_noop("Perl initialization code to execute when a Perl interpreter is initialized."), + NULL, + &plperl_on_init, + NULL, + PGC_SIGHUP, 0, + NULL, NULL, NULL); + + /* + * plperl.on_plperl_init is marked PGC_SUSET to avoid issues whereby a + * user who might not even have USAGE privilege on the plperl language + * could nonetheless use SET plperl.on_plperl_init='...' to influence the + * behaviour of any existing plperl function that they can execute (which + * might be SECURITY DEFINER, leading to a privilege escalation). See + * http://archives.postgresql.org/pgsql-hackers/2010-02/msg00281.php and + * the overall thread. + * + * Note that because plperl.use_strict is USERSET, a nefarious user could + * set it to be applied against other people's functions. This is judged + * OK since the worst result would be an error. Your code oughta pass + * use_strict anyway ;-) + */ + DefineCustomStringVariable("plperl.on_plperl_init", + gettext_noop("Perl initialization code to execute once when plperl is first used."), + NULL, + &plperl_on_plperl_init, + NULL, + PGC_SUSET, 0, + NULL, NULL, NULL); + + DefineCustomStringVariable("plperl.on_plperlu_init", + gettext_noop("Perl initialization code to execute once when plperlu is first used."), + NULL, + &plperl_on_plperlu_init, + NULL, + PGC_SUSET, 0, + NULL, NULL, NULL); + + EmitWarningsOnPlaceholders("plperl"); + + /* + * Create hash tables. + */ + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = sizeof(Oid); + hash_ctl.entrysize = sizeof(plperl_interp_desc); + plperl_interp_hash = hash_create("PL/Perl interpreters", + 8, + &hash_ctl, + HASH_ELEM | HASH_BLOBS); + + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = sizeof(plperl_proc_key); + hash_ctl.entrysize = sizeof(plperl_proc_ptr); + plperl_proc_hash = hash_create("PL/Perl procedures", + 32, + &hash_ctl, + HASH_ELEM | HASH_BLOBS); + + /* + * Save the default opmask. + */ + PLPERL_SET_OPMASK(plperl_opmask); + + /* + * Create the first Perl interpreter, but only partially initialize it. + */ + plperl_held_interp = plperl_init_interp(); + + inited = true; +} + + +static void +set_interp_require(bool trusted) +{ + if (trusted) + { + PL_ppaddr[OP_REQUIRE] = pp_require_safe; + PL_ppaddr[OP_DOFILE] = pp_require_safe; + } + else + { + PL_ppaddr[OP_REQUIRE] = pp_require_orig; + PL_ppaddr[OP_DOFILE] = pp_require_orig; + } +} + +/* + * 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(int code, Datum arg) +{ + HASH_SEQ_STATUS hash_seq; + plperl_interp_desc *interp_desc; + + elog(DEBUG3, "plperl_fini"); + + /* + * Indicate that perl is terminating. Disables use of spi_* functions when + * running END/DESTROY code. See check_spi_usage_allowed(). Could be + * enabled in future, with care, using a transaction + * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02743.php + */ + plperl_ending = true; + + /* Only perform perl cleanup if we're exiting cleanly */ + if (code) + { + elog(DEBUG3, "plperl_fini: skipped"); + return; + } + + /* Zap the "held" interpreter, if we still have it */ + plperl_destroy_interp(&plperl_held_interp); + + /* Zap any fully-initialized interpreters */ + hash_seq_init(&hash_seq, plperl_interp_hash); + while ((interp_desc = hash_seq_search(&hash_seq)) != NULL) + { + if (interp_desc->interp) + { + activate_interpreter(interp_desc); + plperl_destroy_interp(&interp_desc->interp); + } + } + + elog(DEBUG3, "plperl_fini: done"); +} + + +/* + * Select and activate an appropriate Perl interpreter. + */ +static void +select_perl_context(bool trusted) +{ + Oid user_id; + plperl_interp_desc *interp_desc; + bool found; + PerlInterpreter *interp = NULL; + + /* Find or create the interpreter hashtable entry for this userid */ + if (trusted) + user_id = GetUserId(); + else + user_id = InvalidOid; + + interp_desc = hash_search(plperl_interp_hash, &user_id, + HASH_ENTER, + &found); + if (!found) + { + /* Initialize newly-created hashtable entry */ + interp_desc->interp = NULL; + interp_desc->query_hash = NULL; + } + + /* Make sure we have a query_hash for this interpreter */ + if (interp_desc->query_hash == NULL) + { + HASHCTL hash_ctl; + + memset(&hash_ctl, 0, sizeof(hash_ctl)); + hash_ctl.keysize = NAMEDATALEN; + hash_ctl.entrysize = sizeof(plperl_query_entry); + interp_desc->query_hash = hash_create("PL/Perl queries", + 32, + &hash_ctl, + HASH_ELEM); + } + + /* + * Quick exit if already have an interpreter + */ + if (interp_desc->interp) + { + activate_interpreter(interp_desc); + return; + } + + /* + * adopt held interp if free, else create new one if possible + */ + if (plperl_held_interp != NULL) + { + /* first actual use of a perl interpreter */ + interp = plperl_held_interp; + + /* + * Reset the plperl_held_interp pointer first; if we fail during init + * we don't want to try again with the partially-initialized interp. + */ + plperl_held_interp = NULL; + + if (trusted) + plperl_trusted_init(); + else + plperl_untrusted_init(); + + /* successfully initialized, so arrange for cleanup */ + on_proc_exit(plperl_fini, 0); + } + else + { +#ifdef MULTIPLICITY + + /* + * plperl_init_interp will change Perl's idea of the active + * interpreter. Reset plperl_active_interp temporarily, so that if we + * hit an error partway through here, we'll make sure to switch back + * to a non-broken interpreter before running any other Perl + * functions. + */ + plperl_active_interp = NULL; + + /* Now build the new interpreter */ + interp = plperl_init_interp(); + + if (trusted) + plperl_trusted_init(); + else + plperl_untrusted_init(); +#else + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("cannot allocate multiple Perl interpreters on this platform"))); +#endif + } + + set_interp_require(trusted); + + /* + * Since the timing of first use of PL/Perl can't be predicted, any + * database interaction during initialization is problematic. Including, + * but not limited to, security definer issues. So we only enable access + * to the database AFTER on_*_init code has run. See + * http://archives.postgresql.org/pgsql-hackers/2010-01/msg02669.php + */ + { + dTHX; + + newXS("PostgreSQL::InServer::SPI::bootstrap", + boot_PostgreSQL__InServer__SPI, __FILE__); + + eval_pv("PostgreSQL::InServer::SPI::bootstrap()", FALSE); + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing PostgreSQL::InServer::SPI::bootstrap"))); + } + + /* Fully initialized, so mark the hashtable entry valid */ + interp_desc->interp = interp; + + /* And mark this as the active interpreter */ + plperl_active_interp = interp_desc; +} + +/* + * Make the specified interpreter the active one + * + * A call with NULL does nothing. This is so that "restoring" to a previously + * null state of plperl_active_interp doesn't result in useless thrashing. + */ +static void +activate_interpreter(plperl_interp_desc *interp_desc) +{ + if (interp_desc && plperl_active_interp != interp_desc) + { + Assert(interp_desc->interp); + PERL_SET_CONTEXT(interp_desc->interp); + /* trusted iff user_id isn't InvalidOid */ + set_interp_require(OidIsValid(interp_desc->user_id)); + plperl_active_interp = interp_desc; + } +} + +/* + * Create a new Perl interpreter. + * + * We initialize the interpreter as far as we can without knowing whether + * it will become a trusted or untrusted interpreter; in particular, the + * plperl.on_init code will get executed. Later, either plperl_trusted_init + * or plperl_untrusted_init must be called to complete the initialization. + */ +static PerlInterpreter * +plperl_init_interp(void) +{ + PerlInterpreter *plperl; + + static char *embedding[3 + 2] = { + "", "-e", PLC_PERLBOOT + }; + int nargs = 3; + +#ifdef WIN32 + + /* + * The perl library on startup does horrible things like call + * setlocale(LC_ALL,""). We have protected against that on most platforms + * by setting the environment appropriately. However, on Windows, + * setlocale() does not consult the environment, so we need to save the + * existing locale settings before perl has a chance to mangle them and + * restore them after its dirty deeds are done. + * + * MSDN ref: + * http://msdn.microsoft.com/library/en-us/vclib/html/_crt_locale.asp + * + * It appears that we only need to do this on interpreter startup, and + * subsequent calls to the interpreter don't mess with the locale + * settings. + * + * We restore them using setlocale_perl(), defined below, so that Perl + * doesn't have a different idea of the locale from Postgres. + * + */ + + char *loc; + char *save_collate, + *save_ctype, + *save_monetary, + *save_numeric, + *save_time; + + loc = setlocale(LC_COLLATE, NULL); + save_collate = loc ? pstrdup(loc) : NULL; + loc = setlocale(LC_CTYPE, NULL); + save_ctype = loc ? pstrdup(loc) : NULL; + loc = setlocale(LC_MONETARY, NULL); + save_monetary = loc ? pstrdup(loc) : NULL; + loc = setlocale(LC_NUMERIC, NULL); + save_numeric = loc ? pstrdup(loc) : NULL; + loc = setlocale(LC_TIME, NULL); + save_time = loc ? pstrdup(loc) : NULL; + +#define PLPERL_RESTORE_LOCALE(name, saved) \ + STMT_START { \ + if (saved != NULL) { setlocale_perl(name, saved); pfree(saved); } \ + } STMT_END +#endif /* WIN32 */ + + if (plperl_on_init && *plperl_on_init) + { + embedding[nargs++] = "-e"; + embedding[nargs++] = plperl_on_init; + } + + /* + * The perl API docs state that PERL_SYS_INIT3 should be called before + * allocating interpreters. Unfortunately, on some platforms this fails in + * the Perl_do_taint() routine, which is called when the platform is using + * the system's malloc() instead of perl's own. Other platforms, notably + * Windows, fail if PERL_SYS_INIT3 is not called. So we call it if it's + * available, unless perl is using the system malloc(), which is true when + * MYMALLOC is set. + */ +#if defined(PERL_SYS_INIT3) && !defined(MYMALLOC) + { + static int perl_sys_init_done; + + /* 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); + + /* + * For unclear reasons, PERL_SYS_INIT3 sets the SIGFPE handler to + * SIG_IGN. Aside from being extremely unfriendly behavior for a + * library, this is dumb on the grounds that the results of a + * SIGFPE in this state are undefined according to POSIX, and in + * fact you get a forced process kill at least on Linux. Hence, + * restore the SIGFPE handler to the backend's standard setting. + * (See Perl bug 114574 for more information.) + */ + pqsignal(SIGFPE, FloatExceptionHandler); + + perl_sys_init_done = 1; + /* quiet warning if PERL_SYS_INIT3 doesn't use the third argument */ + dummy_env[0] = NULL; + } + } +#endif + + plperl = perl_alloc(); + if (!plperl) + elog(ERROR, "could not allocate Perl interpreter"); + + PERL_SET_CONTEXT(plperl); + perl_construct(plperl); + + /* + * Run END blocks in perl_destruct instead of perl_run. Note that dTHX + * loads up a pointer to the current interpreter, so we have to postpone + * it to here rather than put it at the function head. + */ + { + dTHX; + + PL_exit_flags |= PERL_EXIT_DESTRUCT_END; + + /* + * Record the original function for the 'require' and 'dofile' + * opcodes. (They share the same implementation.) Ensure it's used + * for new interpreters. + */ + if (!pp_require_orig) + pp_require_orig = PL_ppaddr[OP_REQUIRE]; + else + { + PL_ppaddr[OP_REQUIRE] = pp_require_orig; + PL_ppaddr[OP_DOFILE] = pp_require_orig; + } + +#ifdef PLPERL_ENABLE_OPMASK_EARLY + + /* + * For regression testing to prove that the PLC_PERLBOOT and + * PLC_TRUSTED code doesn't even compile any unsafe ops. In future + * there may be a valid need for them to do so, in which case this + * could be softened (perhaps moved to plperl_trusted_init()) or + * removed. + */ + PL_op_mask = plperl_opmask; +#endif + + if (perl_parse(plperl, plperl_init_shared_libs, + nargs, embedding, NULL) != 0) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while parsing Perl initialization"))); + + if (perl_run(plperl) != 0) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while running Perl initialization"))); + +#ifdef PLPERL_RESTORE_LOCALE + PLPERL_RESTORE_LOCALE(LC_COLLATE, save_collate); + PLPERL_RESTORE_LOCALE(LC_CTYPE, save_ctype); + PLPERL_RESTORE_LOCALE(LC_MONETARY, save_monetary); + PLPERL_RESTORE_LOCALE(LC_NUMERIC, save_numeric); + PLPERL_RESTORE_LOCALE(LC_TIME, save_time); +#endif + } + + return plperl; +} + + +/* + * 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 iff Foo has already been loaded. + */ +static OP * +pp_require_safe(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); + + /* + * In most Perl versions, DIE() expands to a return statement, so the next + * line is not necessary. But in versions between but not including + * 5.11.1 and 5.13.3 it does not, so the next line is necessary to avoid a + * "control reaches end of non-void function" warning from gcc. Other + * compilers such as Solaris Studio will, however, issue a "statement not + * reached" warning instead. + */ + return NULL; +} + + +/* + * Destroy one Perl interpreter ... actually we just run END blocks. + * + * Caller must have ensured this interpreter is the active one. + */ +static void +plperl_destroy_interp(PerlInterpreter **interp) +{ + if (interp && *interp) + { + /* + * Only a very minimal destruction is performed: - just call END + * blocks. + * + * We could call perl_destruct() but we'd need to audit its actions + * very carefully and work-around any that impact us. (Calling + * sv_clean_objs() isn't an option because it's not part of perl's + * public API so isn't portably available.) Meanwhile END blocks can + * be used to perform manual cleanup. + */ + dTHX; + + /* Run END blocks - based on perl's perl_destruct() */ + if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) + { + dJMPENV; + int x = 0; + + JMPENV_PUSH(x); + PERL_UNUSED_VAR(x); + if (PL_endav && !PL_minus_c) + call_list(PL_scopestack_ix, PL_endav); + JMPENV_POP; + } + LEAVE; + FREETMPS; + + *interp = NULL; + } +} + +/* + * Initialize the current Perl interpreter as a trusted interp + */ +static void +plperl_trusted_init(void) +{ + dTHX; + HV *stash; + SV *sv; + char *key; + I32 klen; + + /* use original require while we set up */ + PL_ppaddr[OP_REQUIRE] = pp_require_orig; + PL_ppaddr[OP_DOFILE] = pp_require_orig; + + eval_pv(PLC_TRUSTED, FALSE); + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing PLC_TRUSTED"))); + + /* + * Force loading of utf8 module now to prevent 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 + */ + eval_pv("my $a=chr(0x100); return $a =~ /\\xa9/i", FALSE); + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing utf8fix"))); + + /* + * Lock down the interpreter + */ + + /* switch to the safe require/dofile opcode for future code */ + PL_ppaddr[OP_REQUIRE] = pp_require_safe; + PL_ppaddr[OP_DOFILE] = pp_require_safe; + + /* + * prevent (any more) unsafe opcodes being compiled PL_op_mask is per + * interpreter, so this only needs to be set once + */ + PL_op_mask = plperl_opmask; + + /* delete the DynaLoader:: namespace so extensions can't be loaded */ + stash = gv_stashpv("DynaLoader", GV_ADDWARN); + hv_iterinit(stash); + while ((sv = hv_iternextsv(stash, &key, &klen))) + { + if (!isGV_with_GP(sv) || !GvCV(sv)) + continue; + SvREFCNT_dec(GvCV(sv)); /* free the CV */ + GvCV_set(sv, NULL); /* prevent call via GV */ + } + hv_clear(stash); + + /* invalidate assorted caches */ + ++PL_sub_generation; + hv_clear(PL_stashcache); + + /* + * Execute plperl.on_plperl_init in the locked-down interpreter + */ + if (plperl_on_plperl_init && *plperl_on_plperl_init) + { + eval_pv(plperl_on_plperl_init, FALSE); + /* XXX need to find a way to determine a better errcode here */ + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing plperl.on_plperl_init"))); + } +} + + +/* + * Initialize the current Perl interpreter as an untrusted interp + */ +static void +plperl_untrusted_init(void) +{ + dTHX; + + /* + * Nothing to do except execute plperl.on_plperlu_init + */ + if (plperl_on_plperlu_init && *plperl_on_plperlu_init) + { + eval_pv(plperl_on_plperlu_init, FALSE); + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))), + errcontext("while executing plperl.on_plperlu_init"))); + } +} + + +/* + * Perl likes to put a newline after its error messages; clean up such + */ +static char * +strip_trailing_ws(const char *msg) +{ + char *res = pstrdup(msg); + int len = strlen(res); + + while (len > 0 && isspace((unsigned char) res[len - 1])) + res[--len] = '\0'; + return res; +} + + +/* Build a tuple from a hash. */ + +static HeapTuple +plperl_build_tuple_result(HV *perlhash, TupleDesc td) +{ + dTHX; + Datum *values; + bool *nulls; + HE *he; + HeapTuple tup; + + values = palloc0(sizeof(Datum) * td->natts); + nulls = palloc(sizeof(bool) * td->natts); + memset(nulls, true, sizeof(bool) * td->natts); + + hv_iterinit(perlhash); + while ((he = hv_iternext(perlhash))) + { + SV *val = HeVAL(he); + char *key = hek2cstr(he); + int attn = SPI_fnumber(td, key); + Form_pg_attribute attr = TupleDescAttr(td, attn - 1); + + if (attn == SPI_ERROR_NOATTRIBUTE) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_COLUMN), + errmsg("Perl hash contains nonexistent column \"%s\"", + key))); + if (attn <= 0) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("cannot set system attribute \"%s\"", + key))); + + values[attn - 1] = plperl_sv_to_datum(val, + attr->atttypid, + attr->atttypmod, + NULL, + NULL, + InvalidOid, + &nulls[attn - 1]); + + pfree(key); + } + hv_iterinit(perlhash); + + tup = heap_form_tuple(td, values, nulls); + pfree(values); + pfree(nulls); + return tup; +} + +/* convert a hash reference to a datum */ +static Datum +plperl_hash_to_datum(SV *src, TupleDesc td) +{ + HeapTuple tup = plperl_build_tuple_result((HV *) SvRV(src), td); + + return HeapTupleGetDatum(tup); +} + +/* + * if we are an array ref return the reference. this is special in that if we + * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array. + */ +static SV * +get_perl_array_ref(SV *sv) +{ + dTHX; + + if (SvOK(sv) && SvROK(sv)) + { + if (SvTYPE(SvRV(sv)) == SVt_PVAV) + return sv; + else if (sv_isa(sv, "PostgreSQL::InServer::ARRAY")) + { + HV *hv = (HV *) SvRV(sv); + SV **sav = hv_fetch_string(hv, "array"); + + if (*sav && SvOK(*sav) && SvROK(*sav) && + SvTYPE(SvRV(*sav)) == SVt_PVAV) + return *sav; + + elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object"); + } + } + return NULL; +} + +/* + * helper function for plperl_array_to_datum, recurses for multi-D arrays + */ +static void +array_to_datum_internal(AV *av, ArrayBuildState *astate, + int *ndims, int *dims, int cur_depth, + Oid arraytypid, Oid elemtypid, int32 typmod, + FmgrInfo *finfo, Oid typioparam) +{ + dTHX; + int i; + int len = av_len(av) + 1; + + for (i = 0; i < len; i++) + { + /* fetch the array element */ + SV **svp = av_fetch(av, i, FALSE); + + /* see if this element is an array, if so get that */ + SV *sav = svp ? get_perl_array_ref(*svp) : NULL; + + /* multi-dimensional array? */ + if (sav) + { + AV *nav = (AV *) SvRV(sav); + + /* dimensionality checks */ + if (cur_depth + 1 > MAXDIM) + ereport(ERROR, + (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), + errmsg("number of array dimensions (%d) exceeds the maximum allowed (%d)", + cur_depth + 1, MAXDIM))); + + /* set size when at first element in this level, else compare */ + if (i == 0 && *ndims == cur_depth) + { + dims[*ndims] = av_len(nav) + 1; + (*ndims)++; + } + else if (av_len(nav) + 1 != dims[cur_depth]) + ereport(ERROR, + (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION), + errmsg("multidimensional arrays must have array expressions with matching dimensions"))); + + /* recurse to fetch elements of this sub-array */ + array_to_datum_internal(nav, astate, + ndims, dims, cur_depth + 1, + arraytypid, elemtypid, typmod, + finfo, typioparam); + } + else + { + Datum dat; + bool isnull; + + /* scalar after some sub-arrays at same level? */ + if (*ndims != cur_depth) + ereport(ERROR, + (errcode(ERRCODE_INVALID_TEXT_REPRESENTATION), + errmsg("multidimensional arrays must have array expressions with matching dimensions"))); + + dat = plperl_sv_to_datum(svp ? *svp : NULL, + elemtypid, + typmod, + NULL, + finfo, + typioparam, + &isnull); + + (void) accumArrayResult(astate, dat, isnull, + elemtypid, CurrentMemoryContext); + } + } +} + +/* + * convert perl array ref to a datum + */ +static Datum +plperl_array_to_datum(SV *src, Oid typid, int32 typmod) +{ + dTHX; + ArrayBuildState *astate; + Oid elemtypid; + FmgrInfo finfo; + Oid typioparam; + int dims[MAXDIM]; + int lbs[MAXDIM]; + int ndims = 1; + int i; + + elemtypid = get_element_type(typid); + if (!elemtypid) + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("cannot convert Perl array to non-array type %s", + format_type_be(typid)))); + + astate = initArrayResult(elemtypid, CurrentMemoryContext, true); + + _sv_to_datum_finfo(elemtypid, &finfo, &typioparam); + + memset(dims, 0, sizeof(dims)); + dims[0] = av_len((AV *) SvRV(src)) + 1; + + array_to_datum_internal((AV *) SvRV(src), astate, + &ndims, dims, 1, + typid, elemtypid, typmod, + &finfo, typioparam); + + /* ensure we get zero-D array for no inputs, as per PG convention */ + if (dims[0] <= 0) + ndims = 0; + + for (i = 0; i < ndims; i++) + lbs[i] = 1; + + return makeMdArrayResult(astate, ndims, dims, lbs, + CurrentMemoryContext, true); +} + +/* Get the information needed to convert data to the specified PG type */ +static void +_sv_to_datum_finfo(Oid typid, FmgrInfo *finfo, Oid *typioparam) +{ + Oid typinput; + + /* XXX would be better to cache these lookups */ + getTypeInputInfo(typid, + &typinput, typioparam); + fmgr_info(typinput, finfo); +} + +/* + * convert Perl SV to PG datum of type typid, typmod typmod + * + * Pass the PL/Perl function's fcinfo when attempting to convert to the + * function's result type; otherwise pass NULL. This is used when we need to + * resolve the actual result type of a function returning RECORD. + * + * finfo and typioparam should be the results of _sv_to_datum_finfo for the + * given typid, or NULL/InvalidOid to let this function do the lookups. + * + * *isnull is an output parameter. + */ +static Datum +plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod, + FunctionCallInfo fcinfo, + FmgrInfo *finfo, Oid typioparam, + bool *isnull) +{ + FmgrInfo tmp; + Oid funcid; + + /* we might recurse */ + check_stack_depth(); + + *isnull = false; + + /* + * Return NULL if result is undef, or if we're in a function returning + * VOID. In the latter case, we should pay no attention to the last Perl + * statement's result, and this is a convenient means to ensure that. + */ + if (!sv || !SvOK(sv) || typid == VOIDOID) + { + /* look up type info if they did not pass it */ + if (!finfo) + { + _sv_to_datum_finfo(typid, &tmp, &typioparam); + finfo = &tmp; + } + *isnull = true; + /* must call typinput in case it wants to reject NULL */ + return InputFunctionCall(finfo, NULL, typioparam, typmod); + } + else if ((funcid = get_transform_tosql(typid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes))) + return OidFunctionCall1(funcid, PointerGetDatum(sv)); + else if (SvROK(sv)) + { + /* handle references */ + SV *sav = get_perl_array_ref(sv); + + if (sav) + { + /* handle an arrayref */ + return plperl_array_to_datum(sav, typid, typmod); + } + else if (SvTYPE(SvRV(sv)) == SVt_PVHV) + { + /* handle a hashref */ + Datum ret; + TupleDesc td; + bool isdomain; + + if (!type_is_rowtype(typid)) + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("cannot convert Perl hash to non-composite type %s", + format_type_be(typid)))); + + td = lookup_rowtype_tupdesc_domain(typid, typmod, true); + if (td != NULL) + { + /* Did we look through a domain? */ + isdomain = (typid != td->tdtypeid); + } + else + { + /* Must be RECORD, try to resolve based on call info */ + TypeFuncClass funcclass; + + if (fcinfo) + funcclass = get_call_result_type(fcinfo, &typid, &td); + else + funcclass = TYPEFUNC_OTHER; + if (funcclass != TYPEFUNC_COMPOSITE && + funcclass != TYPEFUNC_COMPOSITE_DOMAIN) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("function returning record called in context " + "that cannot accept type record"))); + Assert(td); + isdomain = (funcclass == TYPEFUNC_COMPOSITE_DOMAIN); + } + + ret = plperl_hash_to_datum(sv, td); + + if (isdomain) + domain_check(ret, false, typid, NULL, NULL); + + /* Release on the result of get_call_result_type is harmless */ + ReleaseTupleDesc(td); + + return ret; + } + + /* + * If it's a reference to something else, such as a scalar, just + * recursively look through the reference. + */ + return plperl_sv_to_datum(SvRV(sv), typid, typmod, + fcinfo, finfo, typioparam, + isnull); + } + else + { + /* handle a string/number */ + Datum ret; + char *str = sv2cstr(sv); + + /* did not pass in any typeinfo? look it up */ + if (!finfo) + { + _sv_to_datum_finfo(typid, &tmp, &typioparam); + finfo = &tmp; + } + + ret = InputFunctionCall(finfo, str, typioparam, typmod); + pfree(str); + + return ret; + } +} + +/* Convert the perl SV to a string returned by the type output function */ +char * +plperl_sv_to_literal(SV *sv, char *fqtypename) +{ + Datum str = CStringGetDatum(fqtypename); + Oid typid = DirectFunctionCall1(regtypein, str); + Oid typoutput; + Datum datum; + bool typisvarlena, + isnull; + + if (!OidIsValid(typid)) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_OBJECT), + errmsg("lookup failed for type %s", fqtypename))); + + datum = plperl_sv_to_datum(sv, + typid, -1, + NULL, NULL, InvalidOid, + &isnull); + + if (isnull) + return NULL; + + getTypeOutputInfo(typid, + &typoutput, &typisvarlena); + + return OidOutputFunctionCall(typoutput, datum); +} + +/* + * Convert PostgreSQL array datum to a perl array reference. + * + * typid is arg's OID, which must be an array type. + */ +static SV * +plperl_ref_from_pg_array(Datum arg, Oid typid) +{ + dTHX; + ArrayType *ar = DatumGetArrayTypeP(arg); + Oid elementtype = ARR_ELEMTYPE(ar); + int16 typlen; + bool typbyval; + char typalign, + typdelim; + Oid typioparam; + Oid typoutputfunc; + Oid transform_funcid; + int i, + nitems, + *dims; + plperl_array_info *info; + SV *av; + HV *hv; + + /* + * Currently we make no effort to cache any of the stuff we look up here, + * which is bad. + */ + info = palloc0(sizeof(plperl_array_info)); + + /* get element type information, including output conversion function */ + get_type_io_data(elementtype, IOFunc_output, + &typlen, &typbyval, &typalign, + &typdelim, &typioparam, &typoutputfunc); + + /* Check for a transform function */ + transform_funcid = get_transform_fromsql(elementtype, + current_call_data->prodesc->lang_oid, + current_call_data->prodesc->trftypes); + + /* Look up transform or output function as appropriate */ + if (OidIsValid(transform_funcid)) + fmgr_info(transform_funcid, &info->transform_proc); + else + fmgr_info(typoutputfunc, &info->proc); + + info->elem_is_rowtype = type_is_rowtype(elementtype); + + /* Get the number and bounds of array dimensions */ + info->ndims = ARR_NDIM(ar); + dims = ARR_DIMS(ar); + + /* No dimensions? Return an empty array */ + if (info->ndims == 0) + { + av = newRV_noinc((SV *) newAV()); + } + else + { + deconstruct_array(ar, elementtype, typlen, typbyval, + typalign, &info->elements, &info->nulls, + &nitems); + + /* Get total number of elements in each dimension */ + info->nelems = palloc(sizeof(int) * info->ndims); + info->nelems[0] = nitems; + for (i = 1; i < info->ndims; i++) + info->nelems[i] = info->nelems[i - 1] / dims[i - 1]; + + av = split_array(info, 0, nitems, 0); + } + + hv = newHV(); + (void) hv_store(hv, "array", 5, av, 0); + (void) hv_store(hv, "typeoid", 7, newSVuv(typid), 0); + + return sv_bless(newRV_noinc((SV *) hv), + gv_stashpv("PostgreSQL::InServer::ARRAY", 0)); +} + +/* + * Recursively form array references from splices of the initial array + */ +static SV * +split_array(plperl_array_info *info, int first, int last, int nest) +{ + dTHX; + int i; + AV *result; + + /* we should only be called when we have something to split */ + Assert(info->ndims > 0); + + /* since this function recurses, it could be driven to stack overflow */ + check_stack_depth(); + + /* + * Base case, return a reference to a single-dimensional array + */ + if (nest >= info->ndims - 1) + return make_array_ref(info, first, last); + + result = newAV(); + for (i = first; i < last; i += info->nelems[nest + 1]) + { + /* Recursively form references to arrays of lower dimensions */ + SV *ref = split_array(info, i, i + info->nelems[nest + 1], nest + 1); + + av_push(result, ref); + } + return newRV_noinc((SV *) result); +} + +/* + * Create a Perl reference from a one-dimensional C array, converting + * composite type elements to hash references. + */ +static SV * +make_array_ref(plperl_array_info *info, int first, int last) +{ + dTHX; + int i; + AV *result = newAV(); + + for (i = first; i < last; i++) + { + if (info->nulls[i]) + { + /* + * We can't use &PL_sv_undef here. See "AVs, HVs and undefined + * values" in perlguts. + */ + av_push(result, newSV(0)); + } + else + { + Datum itemvalue = info->elements[i]; + + if (info->transform_proc.fn_oid) + av_push(result, (SV *) DatumGetPointer(FunctionCall1(&info->transform_proc, itemvalue))); + else if (info->elem_is_rowtype) + /* Handle composite type elements */ + av_push(result, plperl_hash_from_datum(itemvalue)); + else + { + char *val = OutputFunctionCall(&info->proc, itemvalue); + + av_push(result, cstr2sv(val)); + } + } + } + return newRV_noinc((SV *) result); +} + +/* Set up the arguments for a trigger call. */ +static SV * +plperl_trigger_build_args(FunctionCallInfo fcinfo) +{ + dTHX; + TriggerData *tdata; + TupleDesc tupdesc; + int i; + char *level; + char *event; + char *relid; + char *when; + HV *hv; + + hv = newHV(); + hv_ksplit(hv, 12); /* pre-grow the hash */ + + tdata = (TriggerData *) fcinfo->context; + tupdesc = tdata->tg_relation->rd_att; + + relid = DatumGetCString(DirectFunctionCall1(oidout, + ObjectIdGetDatum(tdata->tg_relation->rd_id))); + + hv_store_string(hv, "name", cstr2sv(tdata->tg_trigger->tgname)); + hv_store_string(hv, "relid", cstr2sv(relid)); + + /* + * Note: In BEFORE trigger, stored generated columns are not computed yet, + * so don't make them accessible in NEW row. + */ + + if (TRIGGER_FIRED_BY_INSERT(tdata->tg_event)) + { + event = "INSERT"; + if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) + hv_store_string(hv, "new", + plperl_hash_from_tuple(tdata->tg_trigtuple, + tupdesc, + !TRIGGER_FIRED_BEFORE(tdata->tg_event))); + } + else if (TRIGGER_FIRED_BY_DELETE(tdata->tg_event)) + { + event = "DELETE"; + if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) + hv_store_string(hv, "old", + plperl_hash_from_tuple(tdata->tg_trigtuple, + tupdesc, + true)); + } + else if (TRIGGER_FIRED_BY_UPDATE(tdata->tg_event)) + { + event = "UPDATE"; + if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) + { + hv_store_string(hv, "old", + plperl_hash_from_tuple(tdata->tg_trigtuple, + tupdesc, + true)); + hv_store_string(hv, "new", + plperl_hash_from_tuple(tdata->tg_newtuple, + tupdesc, + !TRIGGER_FIRED_BEFORE(tdata->tg_event))); + } + } + else if (TRIGGER_FIRED_BY_TRUNCATE(tdata->tg_event)) + event = "TRUNCATE"; + else + event = "UNKNOWN"; + + hv_store_string(hv, "event", cstr2sv(event)); + hv_store_string(hv, "argc", newSViv(tdata->tg_trigger->tgnargs)); + + if (tdata->tg_trigger->tgnargs > 0) + { + AV *av = newAV(); + + av_extend(av, tdata->tg_trigger->tgnargs); + for (i = 0; i < tdata->tg_trigger->tgnargs; i++) + av_push(av, cstr2sv(tdata->tg_trigger->tgargs[i])); + hv_store_string(hv, "args", newRV_noinc((SV *) av)); + } + + hv_store_string(hv, "relname", + cstr2sv(SPI_getrelname(tdata->tg_relation))); + + hv_store_string(hv, "table_name", + cstr2sv(SPI_getrelname(tdata->tg_relation))); + + hv_store_string(hv, "table_schema", + cstr2sv(SPI_getnspname(tdata->tg_relation))); + + if (TRIGGER_FIRED_BEFORE(tdata->tg_event)) + when = "BEFORE"; + else if (TRIGGER_FIRED_AFTER(tdata->tg_event)) + when = "AFTER"; + else if (TRIGGER_FIRED_INSTEAD(tdata->tg_event)) + when = "INSTEAD OF"; + else + when = "UNKNOWN"; + hv_store_string(hv, "when", cstr2sv(when)); + + if (TRIGGER_FIRED_FOR_ROW(tdata->tg_event)) + level = "ROW"; + else if (TRIGGER_FIRED_FOR_STATEMENT(tdata->tg_event)) + level = "STATEMENT"; + else + level = "UNKNOWN"; + hv_store_string(hv, "level", cstr2sv(level)); + + return newRV_noinc((SV *) hv); +} + + +/* Set up the arguments for an event trigger call. */ +static SV * +plperl_event_trigger_build_args(FunctionCallInfo fcinfo) +{ + dTHX; + EventTriggerData *tdata; + HV *hv; + + hv = newHV(); + + tdata = (EventTriggerData *) fcinfo->context; + + hv_store_string(hv, "event", cstr2sv(tdata->event)); + hv_store_string(hv, "tag", cstr2sv(GetCommandTagName(tdata->tag))); + + return newRV_noinc((SV *) hv); +} + +/* Construct the modified new tuple to be returned from a trigger. */ +static HeapTuple +plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup) +{ + dTHX; + SV **svp; + HV *hvNew; + HE *he; + HeapTuple rtup; + TupleDesc tupdesc; + int natts; + Datum *modvalues; + bool *modnulls; + bool *modrepls; + + svp = hv_fetch_string(hvTD, "new"); + if (!svp) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_COLUMN), + errmsg("$_TD->{new} does not exist"))); + if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV) + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("$_TD->{new} is not a hash reference"))); + hvNew = (HV *) SvRV(*svp); + + tupdesc = tdata->tg_relation->rd_att; + natts = tupdesc->natts; + + modvalues = (Datum *) palloc0(natts * sizeof(Datum)); + modnulls = (bool *) palloc0(natts * sizeof(bool)); + modrepls = (bool *) palloc0(natts * sizeof(bool)); + + hv_iterinit(hvNew); + while ((he = hv_iternext(hvNew))) + { + char *key = hek2cstr(he); + SV *val = HeVAL(he); + int attn = SPI_fnumber(tupdesc, key); + Form_pg_attribute attr = TupleDescAttr(tupdesc, attn - 1); + + if (attn == SPI_ERROR_NOATTRIBUTE) + ereport(ERROR, + (errcode(ERRCODE_UNDEFINED_COLUMN), + errmsg("Perl hash contains nonexistent column \"%s\"", + key))); + if (attn <= 0) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("cannot set system attribute \"%s\"", + key))); + if (attr->attgenerated) + ereport(ERROR, + (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), + errmsg("cannot set generated column \"%s\"", + key))); + + modvalues[attn - 1] = plperl_sv_to_datum(val, + attr->atttypid, + attr->atttypmod, + NULL, + NULL, + InvalidOid, + &modnulls[attn - 1]); + modrepls[attn - 1] = true; + + pfree(key); + } + hv_iterinit(hvNew); + + rtup = heap_modify_tuple(otup, tupdesc, modvalues, modnulls, modrepls); + + pfree(modvalues); + pfree(modnulls); + pfree(modrepls); + + return rtup; +} + + +/* + * There are three externally visible pieces to plperl: plperl_call_handler, + * plperl_inline_handler, and plperl_validator. + */ + +/* + * The call handler is called to run normal functions (including trigger + * functions) that are defined in pg_proc. + */ +PG_FUNCTION_INFO_V1(plperl_call_handler); + +Datum +plperl_call_handler(PG_FUNCTION_ARGS) +{ + Datum retval = (Datum) 0; + plperl_call_data *volatile save_call_data = current_call_data; + plperl_interp_desc *volatile oldinterp = plperl_active_interp; + plperl_call_data this_call_data; + + /* Initialize current-call status record */ + MemSet(&this_call_data, 0, sizeof(this_call_data)); + this_call_data.fcinfo = fcinfo; + + PG_TRY(); + { + current_call_data = &this_call_data; + if (CALLED_AS_TRIGGER(fcinfo)) + retval = PointerGetDatum(plperl_trigger_handler(fcinfo)); + else if (CALLED_AS_EVENT_TRIGGER(fcinfo)) + { + plperl_event_trigger_handler(fcinfo); + retval = (Datum) 0; + } + else + retval = plperl_func_handler(fcinfo); + } + PG_FINALLY(); + { + current_call_data = save_call_data; + activate_interpreter(oldinterp); + if (this_call_data.prodesc) + decrement_prodesc_refcount(this_call_data.prodesc); + } + PG_END_TRY(); + + return retval; +} + +/* + * The inline handler runs anonymous code blocks (DO blocks). + */ +PG_FUNCTION_INFO_V1(plperl_inline_handler); + +Datum +plperl_inline_handler(PG_FUNCTION_ARGS) +{ + LOCAL_FCINFO(fake_fcinfo, 0); + InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0); + FmgrInfo flinfo; + plperl_proc_desc desc; + plperl_call_data *volatile save_call_data = current_call_data; + plperl_interp_desc *volatile oldinterp = plperl_active_interp; + plperl_call_data this_call_data; + ErrorContextCallback pl_error_context; + + /* Initialize current-call status record */ + MemSet(&this_call_data, 0, sizeof(this_call_data)); + + /* Set up a callback for error reporting */ + pl_error_context.callback = plperl_inline_callback; + pl_error_context.previous = error_context_stack; + pl_error_context.arg = NULL; + error_context_stack = &pl_error_context; + + /* + * Set up a fake fcinfo and descriptor with just enough info to satisfy + * plperl_call_perl_func(). In particular note that this sets things up + * with no arguments passed, and a result type of VOID. + */ + MemSet(fake_fcinfo, 0, SizeForFunctionCallInfo(0)); + MemSet(&flinfo, 0, sizeof(flinfo)); + MemSet(&desc, 0, sizeof(desc)); + fake_fcinfo->flinfo = &flinfo; + flinfo.fn_oid = InvalidOid; + flinfo.fn_mcxt = CurrentMemoryContext; + + desc.proname = "inline_code_block"; + desc.fn_readonly = false; + + desc.lang_oid = codeblock->langOid; + desc.trftypes = NIL; + desc.lanpltrusted = codeblock->langIsTrusted; + + desc.fn_retistuple = false; + desc.fn_retisset = false; + desc.fn_retisarray = false; + desc.result_oid = InvalidOid; + desc.nargs = 0; + desc.reference = NULL; + + this_call_data.fcinfo = fake_fcinfo; + this_call_data.prodesc = &desc; + /* we do not bother with refcounting the fake prodesc */ + + PG_TRY(); + { + SV *perlret; + + current_call_data = &this_call_data; + + if (SPI_connect_ext(codeblock->atomic ? 0 : SPI_OPT_NONATOMIC) != SPI_OK_CONNECT) + elog(ERROR, "could not connect to SPI manager"); + + select_perl_context(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"); + + perlret = plperl_call_perl_func(&desc, fake_fcinfo); + + SvREFCNT_dec_current(perlret); + + if (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "SPI_finish() failed"); + } + PG_FINALLY(); + { + if (desc.reference) + SvREFCNT_dec_current(desc.reference); + current_call_data = save_call_data; + activate_interpreter(oldinterp); + } + PG_END_TRY(); + + error_context_stack = pl_error_context.previous; + + PG_RETURN_VOID(); +} + +/* + * The validator is called during CREATE FUNCTION to validate the function + * being created/replaced. The precise behavior of the validator may be + * modified by the check_function_bodies GUC. + */ +PG_FUNCTION_INFO_V1(plperl_validator); + +Datum +plperl_validator(PG_FUNCTION_ARGS) +{ + Oid funcoid = PG_GETARG_OID(0); + HeapTuple tuple; + Form_pg_proc proc; + char functyptype; + int numargs; + Oid *argtypes; + char **argnames; + char *argmodes; + bool is_trigger = false; + bool is_event_trigger = false; + int i; + + if (!CheckFunctionValidatorAccess(fcinfo->flinfo->fn_oid, funcoid)) + PG_RETURN_VOID(); + + /* Get the new function's pg_proc entry */ + tuple = SearchSysCache1(PROCOID, ObjectIdGetDatum(funcoid)); + if (!HeapTupleIsValid(tuple)) + elog(ERROR, "cache lookup failed for function %u", funcoid); + proc = (Form_pg_proc) GETSTRUCT(tuple); + + functyptype = get_typtype(proc->prorettype); + + /* Disallow pseudotype result */ + /* except for TRIGGER, EVTTRIGGER, RECORD, or VOID */ + if (functyptype == TYPTYPE_PSEUDO) + { + if (proc->prorettype == TRIGGEROID) + is_trigger = true; + else if (proc->prorettype == EVTTRIGGEROID) + is_event_trigger = true; + else if (proc->prorettype != RECORDOID && + proc->prorettype != VOIDOID) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("PL/Perl functions cannot return type %s", + format_type_be(proc->prorettype)))); + } + + /* Disallow pseudotypes in arguments (either IN or OUT) */ + numargs = get_func_arg_info(tuple, + &argtypes, &argnames, &argmodes); + for (i = 0; i < numargs; i++) + { + if (get_typtype(argtypes[i]) == TYPTYPE_PSEUDO && + argtypes[i] != RECORDOID) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("PL/Perl functions cannot accept type %s", + format_type_be(argtypes[i])))); + } + + ReleaseSysCache(tuple); + + /* Postpone body checks if !check_function_bodies */ + if (check_function_bodies) + { + (void) compile_plperl_function(funcoid, is_trigger, is_event_trigger); + } + + /* the result of a validator is ignored */ + PG_RETURN_VOID(); +} + + +/* + * plperlu likewise requires three externally visible functions: + * plperlu_call_handler, plperlu_inline_handler, and plperlu_validator. + * These are currently just aliases that send control to the plperl + * handler functions, and we decide whether a particular function is + * trusted or not by inspecting the actual pg_language tuple. + */ + +PG_FUNCTION_INFO_V1(plperlu_call_handler); + +Datum +plperlu_call_handler(PG_FUNCTION_ARGS) +{ + return plperl_call_handler(fcinfo); +} + +PG_FUNCTION_INFO_V1(plperlu_inline_handler); + +Datum +plperlu_inline_handler(PG_FUNCTION_ARGS) +{ + return plperl_inline_handler(fcinfo); +} + +PG_FUNCTION_INFO_V1(plperlu_validator); + +Datum +plperlu_validator(PG_FUNCTION_ARGS) +{ + /* call plperl validator with our fcinfo so it gets our oid */ + return plperl_validator(fcinfo); +} + + +/* + * Uses mkfunc 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, const char *s, Oid fn_oid) +{ + dTHX; + dSP; + char subname[NAMEDATALEN + 40]; + HV *pragma_hv = newHV(); + SV *subref = NULL; + int count; + + 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(cstr2sv(subname))); + PUSHs(sv_2mortal(newRV_noinc((SV *) pragma_hv))); + + /* + * Use 'false' for $prolog in mkfunc, which is kept for compatibility in + * case a module such as PostgreSQL::PLPerl::NYTprof replaces the function + * compiler. + */ + PUSHs(&PL_sv_no); + PUSHs(sv_2mortal(cstr2sv(s))); + PUTBACK; + + /* + * G_KEEPERR seems to be needed here, else we don't recognize compile + * errors properly. Perhaps it's because there's another level of eval + * inside mksafefunc? + */ + count = perl_call_pv("PostgreSQL::InServer::mkfunc", + G_SCALAR | G_EVAL | G_KEEPERR); + SPAGAIN; + + if (count == 1) + { + SV *sub_rv = (SV *) POPs; + + if (sub_rv && SvROK(sub_rv) && SvTYPE(SvRV(sub_rv)) == SVt_PVCV) + { + subref = newRV_inc(SvRV(sub_rv)); + } + } + + PUTBACK; + FREETMPS; + LEAVE; + + if (SvTRUE(ERRSV)) + ereport(ERROR, + (errcode(ERRCODE_SYNTAX_ERROR), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); + + if (!subref) + ereport(ERROR, + (errcode(ERRCODE_SYNTAX_ERROR), + errmsg("didn't get a CODE reference from compiling function \"%s\"", + prodesc->proname))); + + prodesc->reference = subref; +} + + +/********************************************************************** + * plperl_init_shared_libs() - + **********************************************************************/ + +static void +plperl_init_shared_libs(pTHX) +{ + char *file = __FILE__; + + newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); + newXS("PostgreSQL::InServer::Util::bootstrap", + boot_PostgreSQL__InServer__Util, file); + /* newXS for...::SPI::bootstrap is in select_perl_context() */ +} + + +static SV * +plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) +{ + dTHX; + dSP; + SV *retval; + int i; + int count; + Oid *argtypes = NULL; + int nargs = 0; + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + EXTEND(sp, desc->nargs); + + /* Get signature for true functions; inline blocks have no args. */ + if (fcinfo->flinfo->fn_oid) + get_func_signature(fcinfo->flinfo->fn_oid, &argtypes, &nargs); + Assert(nargs == desc->nargs); + + for (i = 0; i < desc->nargs; i++) + { + if (fcinfo->args[i].isnull) + PUSHs(&PL_sv_undef); + else if (desc->arg_is_rowtype[i]) + { + SV *sv = plperl_hash_from_datum(fcinfo->args[i].value); + + PUSHs(sv_2mortal(sv)); + } + else + { + SV *sv; + Oid funcid; + + if (OidIsValid(desc->arg_arraytype[i])) + sv = plperl_ref_from_pg_array(fcinfo->args[i].value, desc->arg_arraytype[i]); + else if ((funcid = get_transform_fromsql(argtypes[i], current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes))) + sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, fcinfo->args[i].value)); + else + { + char *tmp; + + tmp = OutputFunctionCall(&(desc->arg_out_func[i]), + fcinfo->args[i].value); + sv = cstr2sv(tmp); + pfree(tmp); + } + + PUSHs(sv_2mortal(sv)); + } + } + PUTBACK; + + /* Do NOT use G_KEEPERR here */ + count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); + + SPAGAIN; + + if (count != 1) + { + PUTBACK; + FREETMPS; + LEAVE; + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("didn't get a return item from function"))); + } + + if (SvTRUE(ERRSV)) + { + (void) POPs; + PUTBACK; + FREETMPS; + LEAVE; + /* XXX need to find a way to determine a better errcode here */ + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); + } + + retval = newSVsv(POPs); + + PUTBACK; + FREETMPS; + LEAVE; + + return retval; +} + + +static SV * +plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, + SV *td) +{ + dTHX; + dSP; + SV *retval, + *TDsv; + int i, + count; + Trigger *tg_trigger = ((TriggerData *) fcinfo->context)->tg_trigger; + + ENTER; + SAVETMPS; + + TDsv = get_sv("main::_TD", 0); + if (!TDsv) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("couldn't fetch $_TD"))); + + save_item(TDsv); /* local $_TD */ + sv_setsv(TDsv, td); + + PUSHMARK(sp); + EXTEND(sp, tg_trigger->tgnargs); + + for (i = 0; i < tg_trigger->tgnargs; i++) + PUSHs(sv_2mortal(cstr2sv(tg_trigger->tgargs[i]))); + PUTBACK; + + /* Do NOT use G_KEEPERR here */ + count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); + + SPAGAIN; + + if (count != 1) + { + PUTBACK; + FREETMPS; + LEAVE; + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("didn't get a return item from trigger function"))); + } + + if (SvTRUE(ERRSV)) + { + (void) POPs; + PUTBACK; + FREETMPS; + LEAVE; + /* XXX need to find a way to determine a better errcode here */ + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); + } + + retval = newSVsv(POPs); + + PUTBACK; + FREETMPS; + LEAVE; + + return retval; +} + + +static void +plperl_call_perl_event_trigger_func(plperl_proc_desc *desc, + FunctionCallInfo fcinfo, + SV *td) +{ + dTHX; + dSP; + SV *retval, + *TDsv; + int count; + + ENTER; + SAVETMPS; + + TDsv = get_sv("main::_TD", 0); + if (!TDsv) + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("couldn't fetch $_TD"))); + + save_item(TDsv); /* local $_TD */ + sv_setsv(TDsv, td); + + PUSHMARK(sp); + PUTBACK; + + /* Do NOT use G_KEEPERR here */ + count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); + + SPAGAIN; + + if (count != 1) + { + PUTBACK; + FREETMPS; + LEAVE; + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("didn't get a return item from trigger function"))); + } + + if (SvTRUE(ERRSV)) + { + (void) POPs; + PUTBACK; + FREETMPS; + LEAVE; + /* XXX need to find a way to determine a better errcode here */ + ereport(ERROR, + (errcode(ERRCODE_EXTERNAL_ROUTINE_EXCEPTION), + errmsg("%s", strip_trailing_ws(sv2cstr(ERRSV))))); + } + + retval = newSVsv(POPs); + (void) retval; /* silence compiler warning */ + + PUTBACK; + FREETMPS; + LEAVE; +} + +static Datum +plperl_func_handler(PG_FUNCTION_ARGS) +{ + bool nonatomic; + plperl_proc_desc *prodesc; + SV *perlret; + Datum retval = 0; + ReturnSetInfo *rsi; + ErrorContextCallback pl_error_context; + + nonatomic = fcinfo->context && + IsA(fcinfo->context, CallContext) && + !castNode(CallContext, fcinfo->context)->atomic; + + if (SPI_connect_ext(nonatomic ? SPI_OPT_NONATOMIC : 0) != SPI_OK_CONNECT) + elog(ERROR, "could not connect to SPI manager"); + + prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, false); + current_call_data->prodesc = prodesc; + increment_prodesc_refcount(prodesc); + + /* Set a callback for error reporting */ + pl_error_context.callback = plperl_exec_callback; + pl_error_context.previous = error_context_stack; + pl_error_context.arg = prodesc->proname; + error_context_stack = &pl_error_context; + + rsi = (ReturnSetInfo *) fcinfo->resultinfo; + + if (prodesc->fn_retisset) + { + /* Check context before allowing the call to go through */ + if (!rsi || !IsA(rsi, ReturnSetInfo) || + (rsi->allowedModes & SFRM_Materialize) == 0) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("set-valued function called in context that " + "cannot accept a set"))); + } + + activate_interpreter(prodesc->interp); + + perlret = plperl_call_perl_func(prodesc, fcinfo); + + /************************************************************ + * Disconnect from SPI manager and then create the return + * values datum (if the input function does a palloc for it + * this must not be allocated in the SPI memory context + * because SPI_finish would free it). + ************************************************************/ + if (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "SPI_finish() failed"); + + if (prodesc->fn_retisset) + { + SV *sav; + + /* + * If the Perl function returned an arrayref, we pretend that it + * called return_next() for each element of the array, to handle old + * SRFs that didn't know about return_next(). Any other sort of return + * value is an error, except undef which means return an empty set. + */ + sav = get_perl_array_ref(perlret); + if (sav) + { + dTHX; + int i = 0; + SV **svp = 0; + AV *rav = (AV *) SvRV(sav); + + while ((svp = av_fetch(rav, i, FALSE)) != NULL) + { + plperl_return_next_internal(*svp); + i++; + } + } + else if (SvOK(perlret)) + { + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("set-returning PL/Perl function must return " + "reference to array or use return_next"))); + } + + rsi->returnMode = SFRM_Materialize; + if (current_call_data->tuple_store) + { + rsi->setResult = current_call_data->tuple_store; + rsi->setDesc = current_call_data->ret_tdesc; + } + retval = (Datum) 0; + } + else if (prodesc->result_oid) + { + retval = plperl_sv_to_datum(perlret, + prodesc->result_oid, + -1, + fcinfo, + &prodesc->result_in_func, + prodesc->result_typioparam, + &fcinfo->isnull); + + if (fcinfo->isnull && rsi && IsA(rsi, ReturnSetInfo)) + rsi->isDone = ExprEndResult; + } + + /* Restore the previous error callback */ + error_context_stack = pl_error_context.previous; + + SvREFCNT_dec_current(perlret); + + return retval; +} + + +static Datum +plperl_trigger_handler(PG_FUNCTION_ARGS) +{ + plperl_proc_desc *prodesc; + SV *perlret; + Datum retval; + SV *svTD; + HV *hvTD; + ErrorContextCallback pl_error_context; + TriggerData *tdata; + int rc PG_USED_FOR_ASSERTS_ONLY; + + /* Connect to SPI manager */ + if (SPI_connect() != SPI_OK_CONNECT) + elog(ERROR, "could not connect to SPI manager"); + + /* Make transition tables visible to this SPI connection */ + tdata = (TriggerData *) fcinfo->context; + rc = SPI_register_trigger_data(tdata); + Assert(rc >= 0); + + /* Find or compile the function */ + prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, true, false); + current_call_data->prodesc = prodesc; + increment_prodesc_refcount(prodesc); + + /* Set a callback for error reporting */ + pl_error_context.callback = plperl_exec_callback; + pl_error_context.previous = error_context_stack; + pl_error_context.arg = prodesc->proname; + error_context_stack = &pl_error_context; + + activate_interpreter(prodesc->interp); + + svTD = plperl_trigger_build_args(fcinfo); + perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD); + hvTD = (HV *) SvRV(svTD); + + /************************************************************ + * Disconnect from SPI manager and then create the return + * values datum (if the input function does a palloc for it + * this must not be allocated in the SPI memory context + * because SPI_finish would free it). + ************************************************************/ + if (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "SPI_finish() failed"); + + if (perlret == NULL || !SvOK(perlret)) + { + /* undef result means go ahead with original tuple */ + TriggerData *trigdata = ((TriggerData *) fcinfo->context); + + if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) + retval = (Datum) trigdata->tg_trigtuple; + else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) + retval = (Datum) trigdata->tg_newtuple; + else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) + retval = (Datum) trigdata->tg_trigtuple; + else if (TRIGGER_FIRED_BY_TRUNCATE(trigdata->tg_event)) + retval = (Datum) trigdata->tg_trigtuple; + else + retval = (Datum) 0; /* can this happen? */ + } + else + { + HeapTuple trv; + char *tmp; + + tmp = sv2cstr(perlret); + + if (pg_strcasecmp(tmp, "SKIP") == 0) + trv = NULL; + else if (pg_strcasecmp(tmp, "MODIFY") == 0) + { + TriggerData *trigdata = (TriggerData *) fcinfo->context; + + if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) + trv = plperl_modify_tuple(hvTD, trigdata, + trigdata->tg_trigtuple); + else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) + trv = plperl_modify_tuple(hvTD, trigdata, + trigdata->tg_newtuple); + else + { + ereport(WARNING, + (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), + errmsg("ignoring modified row in DELETE trigger"))); + trv = NULL; + } + } + else + { + ereport(ERROR, + (errcode(ERRCODE_E_R_I_E_TRIGGER_PROTOCOL_VIOLATED), + errmsg("result of PL/Perl trigger function must be undef, " + "\"SKIP\", or \"MODIFY\""))); + trv = NULL; + } + retval = PointerGetDatum(trv); + pfree(tmp); + } + + /* Restore the previous error callback */ + error_context_stack = pl_error_context.previous; + + SvREFCNT_dec_current(svTD); + if (perlret) + SvREFCNT_dec_current(perlret); + + return retval; +} + + +static void +plperl_event_trigger_handler(PG_FUNCTION_ARGS) +{ + plperl_proc_desc *prodesc; + SV *svTD; + ErrorContextCallback pl_error_context; + + /* Connect to SPI manager */ + if (SPI_connect() != SPI_OK_CONNECT) + elog(ERROR, "could not connect to SPI manager"); + + /* Find or compile the function */ + prodesc = compile_plperl_function(fcinfo->flinfo->fn_oid, false, true); + current_call_data->prodesc = prodesc; + increment_prodesc_refcount(prodesc); + + /* Set a callback for error reporting */ + pl_error_context.callback = plperl_exec_callback; + pl_error_context.previous = error_context_stack; + pl_error_context.arg = prodesc->proname; + error_context_stack = &pl_error_context; + + activate_interpreter(prodesc->interp); + + svTD = plperl_event_trigger_build_args(fcinfo); + plperl_call_perl_event_trigger_func(prodesc, fcinfo, svTD); + + if (SPI_finish() != SPI_OK_FINISH) + elog(ERROR, "SPI_finish() failed"); + + /* Restore the previous error callback */ + error_context_stack = pl_error_context.previous; + + SvREFCNT_dec_current(svTD); +} + + +static bool +validate_plperl_function(plperl_proc_ptr *proc_ptr, HeapTuple procTup) +{ + if (proc_ptr && proc_ptr->proc_ptr) + { + plperl_proc_desc *prodesc = proc_ptr->proc_ptr; + bool uptodate; + + /************************************************************ + * If it's present, must check whether it's still up to date. + * This is needed because CREATE OR REPLACE FUNCTION can modify the + * function's pg_proc entry without changing its OID. + ************************************************************/ + uptodate = (prodesc->fn_xmin == HeapTupleHeaderGetRawXmin(procTup->t_data) && + ItemPointerEquals(&prodesc->fn_tid, &procTup->t_self)); + + if (uptodate) + return true; + + /* Otherwise, unlink the obsoleted entry from the hashtable ... */ + proc_ptr->proc_ptr = NULL; + /* ... and release the corresponding refcount, probably deleting it */ + decrement_prodesc_refcount(prodesc); + } + + return false; +} + + +static void +free_plperl_function(plperl_proc_desc *prodesc) +{ + Assert(prodesc->fn_refcount == 0); + /* Release CODE reference, if we have one, from the appropriate interp */ + if (prodesc->reference) + { + plperl_interp_desc *oldinterp = plperl_active_interp; + + activate_interpreter(prodesc->interp); + SvREFCNT_dec_current(prodesc->reference); + activate_interpreter(oldinterp); + } + /* Release all PG-owned data for this proc */ + MemoryContextDelete(prodesc->fn_cxt); +} + + +static plperl_proc_desc * +compile_plperl_function(Oid fn_oid, bool is_trigger, bool is_event_trigger) +{ + HeapTuple procTup; + Form_pg_proc procStruct; + plperl_proc_key proc_key; + plperl_proc_ptr *proc_ptr; + plperl_proc_desc *volatile prodesc = NULL; + volatile MemoryContext proc_cxt = NULL; + plperl_interp_desc *oldinterp = plperl_active_interp; + ErrorContextCallback plperl_error_context; + + /* We'll need the pg_proc tuple in any case... */ + procTup = SearchSysCache1(PROCOID, ObjectIdGetDatum(fn_oid)); + if (!HeapTupleIsValid(procTup)) + elog(ERROR, "cache lookup failed for function %u", fn_oid); + procStruct = (Form_pg_proc) GETSTRUCT(procTup); + + /* + * Try to find function in plperl_proc_hash. The reason for this + * overcomplicated-seeming lookup procedure is that we don't know whether + * it's plperl or plperlu, and don't want to spend a lookup in pg_language + * to find out. + */ + proc_key.proc_id = fn_oid; + proc_key.is_trigger = is_trigger; + proc_key.user_id = GetUserId(); + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_FIND, NULL); + if (validate_plperl_function(proc_ptr, procTup)) + { + /* Found valid plperl entry */ + ReleaseSysCache(procTup); + return proc_ptr->proc_ptr; + } + + /* If not found or obsolete, maybe it's plperlu */ + proc_key.user_id = InvalidOid; + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_FIND, NULL); + if (validate_plperl_function(proc_ptr, procTup)) + { + /* Found valid plperlu entry */ + ReleaseSysCache(procTup); + return proc_ptr->proc_ptr; + } + + /************************************************************ + * If we haven't found it in the hashtable, we analyze + * the function's arguments and return type and store + * the in-/out-functions in the prodesc block, + * then we load the procedure into the Perl interpreter, + * and last we create a new hashtable entry for it. + ************************************************************/ + + /* Set a callback for reporting compilation errors */ + plperl_error_context.callback = plperl_compile_callback; + plperl_error_context.previous = error_context_stack; + plperl_error_context.arg = NameStr(procStruct->proname); + error_context_stack = &plperl_error_context; + + PG_TRY(); + { + HeapTuple langTup; + HeapTuple typeTup; + Form_pg_language langStruct; + Form_pg_type typeStruct; + Datum protrftypes_datum; + Datum prosrcdatum; + bool isnull; + char *proc_source; + MemoryContext oldcontext; + + /************************************************************ + * Allocate a context that will hold all PG data for the procedure. + ************************************************************/ + proc_cxt = AllocSetContextCreate(TopMemoryContext, + "PL/Perl function", + ALLOCSET_SMALL_SIZES); + + /************************************************************ + * Allocate and fill a new procedure description block. + * struct prodesc and subsidiary data must all live in proc_cxt. + ************************************************************/ + oldcontext = MemoryContextSwitchTo(proc_cxt); + prodesc = (plperl_proc_desc *) palloc0(sizeof(plperl_proc_desc)); + prodesc->proname = pstrdup(NameStr(procStruct->proname)); + MemoryContextSetIdentifier(proc_cxt, prodesc->proname); + prodesc->fn_cxt = proc_cxt; + prodesc->fn_refcount = 0; + prodesc->fn_xmin = HeapTupleHeaderGetRawXmin(procTup->t_data); + prodesc->fn_tid = procTup->t_self; + prodesc->nargs = procStruct->pronargs; + prodesc->arg_out_func = (FmgrInfo *) palloc0(prodesc->nargs * sizeof(FmgrInfo)); + prodesc->arg_is_rowtype = (bool *) palloc0(prodesc->nargs * sizeof(bool)); + prodesc->arg_arraytype = (Oid *) palloc0(prodesc->nargs * sizeof(Oid)); + MemoryContextSwitchTo(oldcontext); + + /* Remember if function is STABLE/IMMUTABLE */ + prodesc->fn_readonly = + (procStruct->provolatile != PROVOLATILE_VOLATILE); + + /* Fetch protrftypes */ + protrftypes_datum = SysCacheGetAttr(PROCOID, procTup, + Anum_pg_proc_protrftypes, &isnull); + MemoryContextSwitchTo(proc_cxt); + prodesc->trftypes = isnull ? NIL : oid_array_to_list(protrftypes_datum); + MemoryContextSwitchTo(oldcontext); + + /************************************************************ + * Lookup the pg_language tuple by Oid + ************************************************************/ + langTup = SearchSysCache1(LANGOID, + ObjectIdGetDatum(procStruct->prolang)); + if (!HeapTupleIsValid(langTup)) + elog(ERROR, "cache lookup failed for language %u", + procStruct->prolang); + langStruct = (Form_pg_language) GETSTRUCT(langTup); + prodesc->lang_oid = langStruct->oid; + prodesc->lanpltrusted = langStruct->lanpltrusted; + ReleaseSysCache(langTup); + + /************************************************************ + * Get the required information for input conversion of the + * return value. + ************************************************************/ + if (!is_trigger && !is_event_trigger) + { + Oid rettype = procStruct->prorettype; + + typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(rettype)); + if (!HeapTupleIsValid(typeTup)) + elog(ERROR, "cache lookup failed for type %u", rettype); + typeStruct = (Form_pg_type) GETSTRUCT(typeTup); + + /* Disallow pseudotype result, except VOID or RECORD */ + if (typeStruct->typtype == TYPTYPE_PSEUDO) + { + if (rettype == VOIDOID || + rettype == RECORDOID) + /* okay */ ; + else if (rettype == TRIGGEROID || + rettype == EVTTRIGGEROID) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("trigger functions can only be called " + "as triggers"))); + else + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("PL/Perl functions cannot return type %s", + format_type_be(rettype)))); + } + + prodesc->result_oid = rettype; + prodesc->fn_retisset = procStruct->proretset; + prodesc->fn_retistuple = type_is_rowtype(rettype); + + prodesc->fn_retisarray = + (typeStruct->typlen == -1 && typeStruct->typelem); + + fmgr_info_cxt(typeStruct->typinput, + &(prodesc->result_in_func), + proc_cxt); + prodesc->result_typioparam = getTypeIOParam(typeTup); + + ReleaseSysCache(typeTup); + } + + /************************************************************ + * Get the required information for output conversion + * of all procedure arguments + ************************************************************/ + if (!is_trigger && !is_event_trigger) + { + int i; + + for (i = 0; i < prodesc->nargs; i++) + { + Oid argtype = procStruct->proargtypes.values[i]; + + typeTup = SearchSysCache1(TYPEOID, ObjectIdGetDatum(argtype)); + if (!HeapTupleIsValid(typeTup)) + elog(ERROR, "cache lookup failed for type %u", argtype); + typeStruct = (Form_pg_type) GETSTRUCT(typeTup); + + /* Disallow pseudotype argument, except RECORD */ + if (typeStruct->typtype == TYPTYPE_PSEUDO && + argtype != RECORDOID) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("PL/Perl functions cannot accept type %s", + format_type_be(argtype)))); + + if (type_is_rowtype(argtype)) + prodesc->arg_is_rowtype[i] = true; + else + { + prodesc->arg_is_rowtype[i] = false; + fmgr_info_cxt(typeStruct->typoutput, + &(prodesc->arg_out_func[i]), + proc_cxt); + } + + /* Identify array-type arguments */ + if (typeStruct->typelem != 0 && typeStruct->typlen == -1) + prodesc->arg_arraytype[i] = argtype; + else + prodesc->arg_arraytype[i] = InvalidOid; + + ReleaseSysCache(typeTup); + } + } + + /************************************************************ + * create the text of the anonymous subroutine. + * we do not use a named subroutine so that we can call directly + * through the reference. + ************************************************************/ + prosrcdatum = SysCacheGetAttr(PROCOID, procTup, + Anum_pg_proc_prosrc, &isnull); + if (isnull) + elog(ERROR, "null prosrc"); + proc_source = TextDatumGetCString(prosrcdatum); + + /************************************************************ + * Create the procedure in the appropriate interpreter + ************************************************************/ + + select_perl_context(prodesc->lanpltrusted); + + prodesc->interp = plperl_active_interp; + + plperl_create_sub(prodesc, proc_source, fn_oid); + + activate_interpreter(oldinterp); + + pfree(proc_source); + + if (!prodesc->reference) /* can this happen? */ + elog(ERROR, "could not create PL/Perl internal procedure"); + + /************************************************************ + * OK, link the procedure into the correct hashtable entry. + * Note we assume that the hashtable entry either doesn't exist yet, + * or we already cleared its proc_ptr during the validation attempts + * above. So no need to decrement an old refcount here. + ************************************************************/ + proc_key.user_id = prodesc->lanpltrusted ? GetUserId() : InvalidOid; + + proc_ptr = hash_search(plperl_proc_hash, &proc_key, + HASH_ENTER, NULL); + /* We assume these two steps can't throw an error: */ + proc_ptr->proc_ptr = prodesc; + increment_prodesc_refcount(prodesc); + } + PG_CATCH(); + { + /* + * If we got as far as creating a reference, we should be able to use + * free_plperl_function() to clean up. If not, then at most we have + * some PG memory resources in proc_cxt, which we can just delete. + */ + if (prodesc && prodesc->reference) + free_plperl_function(prodesc); + else if (proc_cxt) + MemoryContextDelete(proc_cxt); + + /* Be sure to restore the previous interpreter, too, for luck */ + activate_interpreter(oldinterp); + + PG_RE_THROW(); + } + PG_END_TRY(); + + /* restore previous error callback */ + error_context_stack = plperl_error_context.previous; + + ReleaseSysCache(procTup); + + return prodesc; +} + +/* Build a hash from a given composite/row datum */ +static SV * +plperl_hash_from_datum(Datum attr) +{ + HeapTupleHeader td; + Oid tupType; + int32 tupTypmod; + TupleDesc tupdesc; + HeapTupleData tmptup; + SV *sv; + + td = DatumGetHeapTupleHeader(attr); + + /* Extract rowtype info and find a tupdesc */ + tupType = HeapTupleHeaderGetTypeId(td); + tupTypmod = HeapTupleHeaderGetTypMod(td); + tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); + + /* Build a temporary HeapTuple control structure */ + tmptup.t_len = HeapTupleHeaderGetDatumLength(td); + tmptup.t_data = td; + + sv = plperl_hash_from_tuple(&tmptup, tupdesc, true); + ReleaseTupleDesc(tupdesc); + + return sv; +} + +/* Build a hash from all attributes of a given tuple. */ +static SV * +plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc, bool include_generated) +{ + dTHX; + HV *hv; + int i; + + /* since this function recurses, it could be driven to stack overflow */ + check_stack_depth(); + + hv = newHV(); + hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */ + + for (i = 0; i < tupdesc->natts; i++) + { + Datum attr; + bool isnull, + typisvarlena; + char *attname; + Oid typoutput; + Form_pg_attribute att = TupleDescAttr(tupdesc, i); + + if (att->attisdropped) + continue; + + if (att->attgenerated) + { + /* don't include unless requested */ + if (!include_generated) + continue; + } + + attname = NameStr(att->attname); + attr = heap_getattr(tuple, i + 1, tupdesc, &isnull); + + if (isnull) + { + /* + * Store (attname => undef) and move on. Note we can't use + * &PL_sv_undef here; see "AVs, HVs and undefined values" in + * perlguts for an explanation. + */ + hv_store_string(hv, attname, newSV(0)); + continue; + } + + if (type_is_rowtype(att->atttypid)) + { + SV *sv = plperl_hash_from_datum(attr); + + hv_store_string(hv, attname, sv); + } + else + { + SV *sv; + Oid funcid; + + if (OidIsValid(get_base_element_type(att->atttypid))) + sv = plperl_ref_from_pg_array(attr, att->atttypid); + else if ((funcid = get_transform_fromsql(att->atttypid, current_call_data->prodesc->lang_oid, current_call_data->prodesc->trftypes))) + sv = (SV *) DatumGetPointer(OidFunctionCall1(funcid, attr)); + else + { + char *outputstr; + + /* XXX should have a way to cache these lookups */ + getTypeOutputInfo(att->atttypid, &typoutput, &typisvarlena); + + outputstr = OidOutputFunctionCall(typoutput, attr); + sv = cstr2sv(outputstr); + pfree(outputstr); + } + + hv_store_string(hv, attname, sv); + } + } + return newRV_noinc((SV *) hv); +} + + +static void +check_spi_usage_allowed(void) +{ + /* see comment in plperl_fini() */ + if (plperl_ending) + { + /* simple croak as we don't want to involve PostgreSQL code */ + croak("SPI functions can not be used in END blocks"); + } +} + + +HV * +plperl_spi_exec(char *query, int limit) +{ + HV *ret_hv; + + /* + * Execute the query inside a sub-transaction, so we can cope with errors + * sanely + */ + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + /* Want to run inside function's memory context */ + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + int spi_rv; + + pg_verifymbstr(query, strlen(query), false); + + spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly, + limit); + ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, + spi_rv); + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + return ret_hv; +} + + +static HV * +plperl_spi_execute_fetch_result(SPITupleTable *tuptable, uint64 processed, + int status) +{ + dTHX; + HV *result; + + check_spi_usage_allowed(); + + result = newHV(); + + hv_store_string(result, "status", + cstr2sv(SPI_result_code_string(status))); + hv_store_string(result, "processed", + (processed > (uint64) UV_MAX) ? + newSVnv((NV) processed) : + newSVuv((UV) processed)); + + if (status > 0 && tuptable) + { + AV *rows; + SV *row; + uint64 i; + + /* Prevent overflow in call to av_extend() */ + if (processed > (uint64) AV_SIZE_MAX) + ereport(ERROR, + (errcode(ERRCODE_PROGRAM_LIMIT_EXCEEDED), + errmsg("query result has too many rows to fit in a Perl array"))); + + rows = newAV(); + av_extend(rows, processed); + for (i = 0; i < processed; i++) + { + row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc, true); + av_push(rows, row); + } + hv_store_string(result, "rows", + newRV_noinc((SV *) rows)); + } + + SPI_freetuptable(tuptable); + + return result; +} + + +/* + * plperl_return_next catches any error and converts it to a Perl error. + * We assume (perhaps without adequate justification) that we need not abort + * the current transaction if the Perl code traps the error. + */ +void +plperl_return_next(SV *sv) +{ + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + plperl_return_next_internal(sv); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +/* + * plperl_return_next_internal reports any errors in Postgres fashion + * (via ereport). + */ +static void +plperl_return_next_internal(SV *sv) +{ + plperl_proc_desc *prodesc; + FunctionCallInfo fcinfo; + ReturnSetInfo *rsi; + MemoryContext old_cxt; + + if (!sv) + return; + + prodesc = current_call_data->prodesc; + fcinfo = current_call_data->fcinfo; + rsi = (ReturnSetInfo *) fcinfo->resultinfo; + + if (!prodesc->fn_retisset) + ereport(ERROR, + (errcode(ERRCODE_SYNTAX_ERROR), + errmsg("cannot use return_next in a non-SETOF function"))); + + if (!current_call_data->ret_tdesc) + { + TupleDesc tupdesc; + + Assert(!current_call_data->tuple_store); + + /* + * This is the first call to return_next in the current PL/Perl + * function call, so identify the output tuple type and create a + * tuplestore to hold the result rows. + */ + if (prodesc->fn_retistuple) + { + TypeFuncClass funcclass; + Oid typid; + + funcclass = get_call_result_type(fcinfo, &typid, &tupdesc); + if (funcclass != TYPEFUNC_COMPOSITE && + funcclass != TYPEFUNC_COMPOSITE_DOMAIN) + ereport(ERROR, + (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), + errmsg("function returning record called in context " + "that cannot accept type record"))); + /* if domain-over-composite, remember the domain's type OID */ + if (funcclass == TYPEFUNC_COMPOSITE_DOMAIN) + current_call_data->cdomain_oid = typid; + } + else + { + tupdesc = rsi->expectedDesc; + /* Protect assumption below that we return exactly one column */ + if (tupdesc == NULL || tupdesc->natts != 1) + elog(ERROR, "expected single-column result descriptor for non-composite SETOF result"); + } + + /* + * Make sure the tuple_store and ret_tdesc are sufficiently + * long-lived. + */ + old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory); + + current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc); + current_call_data->tuple_store = + tuplestore_begin_heap(rsi->allowedModes & SFRM_Materialize_Random, + false, work_mem); + + MemoryContextSwitchTo(old_cxt); + } + + /* + * Producing the tuple we want to return requires making plenty of + * palloc() allocations that are not cleaned up. Since this function can + * be called many times before the current memory context is reset, we + * need to do those allocations in a temporary context. + */ + if (!current_call_data->tmp_cxt) + { + current_call_data->tmp_cxt = + AllocSetContextCreate(CurrentMemoryContext, + "PL/Perl return_next temporary cxt", + ALLOCSET_DEFAULT_SIZES); + } + + old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt); + + if (prodesc->fn_retistuple) + { + HeapTuple tuple; + + if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) + ereport(ERROR, + (errcode(ERRCODE_DATATYPE_MISMATCH), + errmsg("SETOF-composite-returning PL/Perl function " + "must call return_next with reference to hash"))); + + tuple = plperl_build_tuple_result((HV *) SvRV(sv), + current_call_data->ret_tdesc); + + if (OidIsValid(current_call_data->cdomain_oid)) + domain_check(HeapTupleGetDatum(tuple), false, + current_call_data->cdomain_oid, + ¤t_call_data->cdomain_info, + rsi->econtext->ecxt_per_query_memory); + + tuplestore_puttuple(current_call_data->tuple_store, tuple); + } + else if (prodesc->result_oid) + { + Datum ret[1]; + bool isNull[1]; + + ret[0] = plperl_sv_to_datum(sv, + prodesc->result_oid, + -1, + fcinfo, + &prodesc->result_in_func, + prodesc->result_typioparam, + &isNull[0]); + + tuplestore_putvalues(current_call_data->tuple_store, + current_call_data->ret_tdesc, + ret, isNull); + } + + MemoryContextSwitchTo(old_cxt); + MemoryContextReset(current_call_data->tmp_cxt); +} + + +SV * +plperl_spi_query(char *query) +{ + SV *cursor; + + /* + * Execute the query inside a sub-transaction, so we can cope with errors + * sanely + */ + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + /* Want to run inside function's memory context */ + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + SPIPlanPtr plan; + Portal portal; + + /* Make sure the query is validly encoded */ + pg_verifymbstr(query, strlen(query), false); + + /* Create a cursor for the query */ + plan = SPI_prepare(query, 0, NULL); + if (plan == NULL) + elog(ERROR, "SPI_prepare() failed:%s", + SPI_result_code_string(SPI_result)); + + portal = SPI_cursor_open(NULL, plan, NULL, NULL, false); + SPI_freeplan(plan); + if (portal == NULL) + elog(ERROR, "SPI_cursor_open() failed:%s", + SPI_result_code_string(SPI_result)); + cursor = cstr2sv(portal->name); + + PinPortal(portal); + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + return cursor; +} + + +SV * +plperl_spi_fetchrow(char *cursor) +{ + SV *row; + + /* + * Execute the FETCH inside a sub-transaction, so we can cope with errors + * sanely + */ + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + /* Want to run inside function's memory context */ + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + dTHX; + Portal p = SPI_cursor_find(cursor); + + if (!p) + { + row = &PL_sv_undef; + } + else + { + SPI_cursor_fetch(p, true, 1); + if (SPI_processed == 0) + { + UnpinPortal(p); + SPI_cursor_close(p); + row = &PL_sv_undef; + } + else + { + row = plperl_hash_from_tuple(SPI_tuptable->vals[0], + SPI_tuptable->tupdesc, + true); + } + SPI_freetuptable(SPI_tuptable); + } + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + return row; +} + +void +plperl_spi_cursor_close(char *cursor) +{ + Portal p; + + check_spi_usage_allowed(); + + p = SPI_cursor_find(cursor); + + if (p) + { + UnpinPortal(p); + SPI_cursor_close(p); + } +} + +SV * +plperl_spi_prepare(char *query, int argc, SV **argv) +{ + volatile SPIPlanPtr plan = NULL; + volatile MemoryContext plan_cxt = NULL; + plperl_query_desc *volatile qdesc = NULL; + plperl_query_entry *volatile hash_entry = NULL; + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + MemoryContext work_cxt; + bool found; + int i; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + CHECK_FOR_INTERRUPTS(); + + /************************************************************ + * Allocate the new querydesc structure + * + * The qdesc struct, as well as all its subsidiary data, lives in its + * plan_cxt. But note that the SPIPlan does not. + ************************************************************/ + plan_cxt = AllocSetContextCreate(TopMemoryContext, + "PL/Perl spi_prepare query", + ALLOCSET_SMALL_SIZES); + MemoryContextSwitchTo(plan_cxt); + qdesc = (plperl_query_desc *) palloc0(sizeof(plperl_query_desc)); + snprintf(qdesc->qname, sizeof(qdesc->qname), "%p", qdesc); + qdesc->plan_cxt = plan_cxt; + qdesc->nargs = argc; + qdesc->argtypes = (Oid *) palloc(argc * sizeof(Oid)); + qdesc->arginfuncs = (FmgrInfo *) palloc(argc * sizeof(FmgrInfo)); + qdesc->argtypioparams = (Oid *) palloc(argc * sizeof(Oid)); + MemoryContextSwitchTo(oldcontext); + + /************************************************************ + * Do the following work in a short-lived context so that we don't + * leak a lot of memory in the PL/Perl function's SPI Proc context. + ************************************************************/ + work_cxt = AllocSetContextCreate(CurrentMemoryContext, + "PL/Perl spi_prepare workspace", + ALLOCSET_DEFAULT_SIZES); + MemoryContextSwitchTo(work_cxt); + + /************************************************************ + * Resolve argument type names and then look them up by oid + * in the system cache, and remember the required information + * for input conversion. + ************************************************************/ + for (i = 0; i < argc; i++) + { + Oid typId, + typInput, + typIOParam; + int32 typmod; + char *typstr; + + typstr = sv2cstr(argv[i]); + parseTypeString(typstr, &typId, &typmod, false); + pfree(typstr); + + getTypeInputInfo(typId, &typInput, &typIOParam); + + qdesc->argtypes[i] = typId; + fmgr_info_cxt(typInput, &(qdesc->arginfuncs[i]), plan_cxt); + qdesc->argtypioparams[i] = typIOParam; + } + + /* Make sure the query is validly encoded */ + pg_verifymbstr(query, strlen(query), false); + + /************************************************************ + * Prepare the plan and check for errors + ************************************************************/ + plan = SPI_prepare(query, argc, qdesc->argtypes); + + if (plan == NULL) + elog(ERROR, "SPI_prepare() failed:%s", + SPI_result_code_string(SPI_result)); + + /************************************************************ + * Save the plan into permanent memory (right now it's in the + * SPI procCxt, which will go away at function end). + ************************************************************/ + if (SPI_keepplan(plan)) + elog(ERROR, "SPI_keepplan() failed"); + qdesc->plan = plan; + + /************************************************************ + * Insert a hashtable entry for the plan. + ************************************************************/ + hash_entry = hash_search(plperl_active_interp->query_hash, + qdesc->qname, + HASH_ENTER, &found); + hash_entry->query_data = qdesc; + + /* Get rid of workspace */ + MemoryContextDelete(work_cxt); + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Drop anything we managed to allocate */ + if (hash_entry) + hash_search(plperl_active_interp->query_hash, + qdesc->qname, + HASH_REMOVE, NULL); + if (plan_cxt) + MemoryContextDelete(plan_cxt); + if (plan) + SPI_freeplan(plan); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + /************************************************************ + * Return the query's hash key to the caller. + ************************************************************/ + return cstr2sv(qdesc->qname); +} + +HV * +plperl_spi_exec_prepared(char *query, HV *attr, int argc, SV **argv) +{ + HV *ret_hv; + SV **sv; + int i, + limit, + spi_rv; + char *nulls; + Datum *argvalues; + plperl_query_desc *qdesc; + plperl_query_entry *hash_entry; + + /* + * Execute the query inside a sub-transaction, so we can cope with errors + * sanely + */ + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + /* Want to run inside function's memory context */ + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + dTHX; + + /************************************************************ + * Fetch the saved plan descriptor, see if it's o.k. + ************************************************************/ + hash_entry = hash_search(plperl_active_interp->query_hash, query, + HASH_FIND, NULL); + if (hash_entry == NULL) + elog(ERROR, "spi_exec_prepared: Invalid prepared query passed"); + + qdesc = hash_entry->query_data; + if (qdesc == NULL) + elog(ERROR, "spi_exec_prepared: plperl query_hash value vanished"); + + if (qdesc->nargs != argc) + elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed", + qdesc->nargs, argc); + + /************************************************************ + * Parse eventual attributes + ************************************************************/ + limit = 0; + if (attr != NULL) + { + sv = hv_fetch_string(attr, "limit"); + if (sv && *sv && SvIOK(*sv)) + limit = SvIV(*sv); + } + /************************************************************ + * Set up arguments + ************************************************************/ + if (argc > 0) + { + nulls = (char *) palloc(argc); + argvalues = (Datum *) palloc(argc * sizeof(Datum)); + } + else + { + nulls = NULL; + argvalues = NULL; + } + + for (i = 0; i < argc; i++) + { + bool isnull; + + argvalues[i] = plperl_sv_to_datum(argv[i], + qdesc->argtypes[i], + -1, + NULL, + &qdesc->arginfuncs[i], + qdesc->argtypioparams[i], + &isnull); + nulls[i] = isnull ? 'n' : ' '; + } + + /************************************************************ + * go + ************************************************************/ + spi_rv = SPI_execute_plan(qdesc->plan, argvalues, nulls, + current_call_data->prodesc->fn_readonly, limit); + ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed, + spi_rv); + if (argc > 0) + { + pfree(argvalues); + pfree(nulls); + } + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + return ret_hv; +} + +SV * +plperl_spi_query_prepared(char *query, int argc, SV **argv) +{ + int i; + char *nulls; + Datum *argvalues; + plperl_query_desc *qdesc; + plperl_query_entry *hash_entry; + SV *cursor; + Portal portal = NULL; + + /* + * Execute the query inside a sub-transaction, so we can cope with errors + * sanely + */ + MemoryContext oldcontext = CurrentMemoryContext; + ResourceOwner oldowner = CurrentResourceOwner; + + check_spi_usage_allowed(); + + BeginInternalSubTransaction(NULL); + /* Want to run inside function's memory context */ + MemoryContextSwitchTo(oldcontext); + + PG_TRY(); + { + /************************************************************ + * Fetch the saved plan descriptor, see if it's o.k. + ************************************************************/ + hash_entry = hash_search(plperl_active_interp->query_hash, query, + HASH_FIND, NULL); + if (hash_entry == NULL) + elog(ERROR, "spi_query_prepared: Invalid prepared query passed"); + + qdesc = hash_entry->query_data; + if (qdesc == NULL) + elog(ERROR, "spi_query_prepared: plperl query_hash value vanished"); + + if (qdesc->nargs != argc) + elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed", + qdesc->nargs, argc); + + /************************************************************ + * Set up arguments + ************************************************************/ + if (argc > 0) + { + nulls = (char *) palloc(argc); + argvalues = (Datum *) palloc(argc * sizeof(Datum)); + } + else + { + nulls = NULL; + argvalues = NULL; + } + + for (i = 0; i < argc; i++) + { + bool isnull; + + argvalues[i] = plperl_sv_to_datum(argv[i], + qdesc->argtypes[i], + -1, + NULL, + &qdesc->arginfuncs[i], + qdesc->argtypioparams[i], + &isnull); + nulls[i] = isnull ? 'n' : ' '; + } + + /************************************************************ + * go + ************************************************************/ + portal = SPI_cursor_open(NULL, qdesc->plan, argvalues, nulls, + current_call_data->prodesc->fn_readonly); + if (argc > 0) + { + pfree(argvalues); + pfree(nulls); + } + if (portal == NULL) + elog(ERROR, "SPI_cursor_open() failed:%s", + SPI_result_code_string(SPI_result)); + + cursor = cstr2sv(portal->name); + + PinPortal(portal); + + /* Commit the inner transaction, return to outer xact context */ + ReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Abort the inner transaction */ + RollbackAndReleaseCurrentSubTransaction(); + MemoryContextSwitchTo(oldcontext); + CurrentResourceOwner = oldowner; + + /* Punt the error to Perl */ + croak_cstr(edata->message); + + /* Can't get here, but keep compiler quiet */ + return NULL; + } + PG_END_TRY(); + + return cursor; +} + +void +plperl_spi_freeplan(char *query) +{ + SPIPlanPtr plan; + plperl_query_desc *qdesc; + plperl_query_entry *hash_entry; + + check_spi_usage_allowed(); + + hash_entry = hash_search(plperl_active_interp->query_hash, query, + HASH_FIND, NULL); + if (hash_entry == NULL) + elog(ERROR, "spi_freeplan: Invalid prepared query passed"); + + qdesc = hash_entry->query_data; + if (qdesc == NULL) + elog(ERROR, "spi_freeplan: plperl query_hash value vanished"); + plan = qdesc->plan; + + /* + * free all memory before SPI_freeplan, so if it dies, nothing will be + * left over + */ + hash_search(plperl_active_interp->query_hash, query, + HASH_REMOVE, NULL); + + MemoryContextDelete(qdesc->plan_cxt); + + SPI_freeplan(plan); +} + +void +plperl_spi_commit(void) +{ + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + SPI_commit(); + SPI_start_transaction(); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +void +plperl_spi_rollback(void) +{ + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + SPI_rollback(); + SPI_start_transaction(); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Save error info */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +/* + * 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. + * + * The main reason this is out-of-line is to avoid conflicts between XSUB.h + * and the PG_TRY macros. + */ +void +plperl_util_elog(int level, SV *msg) +{ + MemoryContext oldcontext = CurrentMemoryContext; + char *volatile cmsg = NULL; + + PG_TRY(); + { + cmsg = sv2cstr(msg); + elog(level, "%s", cmsg); + pfree(cmsg); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + if (cmsg) + pfree(cmsg); + + /* Punt the error to Perl */ + croak_cstr(edata->message); + } + PG_END_TRY(); +} + +/* + * Store an SV into a hash table under a key that is a string assumed to be + * in the current database's encoding. + */ +static SV ** +hv_store_string(HV *hv, const char *key, SV *val) +{ + dTHX; + int32 hlen; + char *hkey; + SV **ret; + + hkey = pg_server_to_any(key, strlen(key), PG_UTF8); + + /* + * hv_store() recognizes a negative klen parameter as meaning a UTF-8 + * encoded key. + */ + hlen = -(int) strlen(hkey); + ret = hv_store(hv, hkey, hlen, val, 0); + + if (hkey != key) + pfree(hkey); + + return ret; +} + +/* + * Fetch an SV from a hash table under a key that is a string assumed to be + * in the current database's encoding. + */ +static SV ** +hv_fetch_string(HV *hv, const char *key) +{ + dTHX; + int32 hlen; + char *hkey; + SV **ret; + + hkey = pg_server_to_any(key, strlen(key), PG_UTF8); + + /* See notes in hv_store_string */ + hlen = -(int) strlen(hkey); + ret = hv_fetch(hv, hkey, hlen, 0); + + if (hkey != key) + pfree(hkey); + + return ret; +} + +/* + * Provide function name for PL/Perl execution errors + */ +static void +plperl_exec_callback(void *arg) +{ + char *procname = (char *) arg; + + if (procname) + errcontext("PL/Perl function \"%s\"", procname); +} + +/* + * Provide function name for PL/Perl compilation errors + */ +static void +plperl_compile_callback(void *arg) +{ + char *procname = (char *) arg; + + if (procname) + errcontext("compilation of PL/Perl function \"%s\"", procname); +} + +/* + * Provide error context for the inline handler + */ +static void +plperl_inline_callback(void *arg) +{ + errcontext("PL/Perl anonymous code block"); +} + + +/* + * Perl's own setlocale(), copied from POSIX.xs + * (needed because of the calls to new_*()) + */ +#ifdef WIN32 +static char * +setlocale_perl(int category, char *locale) +{ + dTHX; + char *RETVAL = setlocale(category, locale); + + if (RETVAL) + { +#ifdef USE_LOCALE_CTYPE + if (category == LC_CTYPE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newctype; + +#ifdef LC_ALL + if (category == LC_ALL) + newctype = setlocale(LC_CTYPE, NULL); + else +#endif + newctype = RETVAL; + new_ctype(newctype); + } +#endif /* USE_LOCALE_CTYPE */ +#ifdef USE_LOCALE_COLLATE + if (category == LC_COLLATE +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newcoll; + +#ifdef LC_ALL + if (category == LC_ALL) + newcoll = setlocale(LC_COLLATE, NULL); + else +#endif + newcoll = RETVAL; + new_collate(newcoll); + } +#endif /* USE_LOCALE_COLLATE */ + +#ifdef USE_LOCALE_NUMERIC + if (category == LC_NUMERIC +#ifdef LC_ALL + || category == LC_ALL +#endif + ) + { + char *newnum; + +#ifdef LC_ALL + if (category == LC_ALL) + newnum = setlocale(LC_NUMERIC, NULL); + else +#endif + newnum = RETVAL; + new_numeric(newnum); + } +#endif /* USE_LOCALE_NUMERIC */ + } + + return RETVAL; +} + +#endif /* WIN32 */ diff --git a/src/pl/plperl/plperl.control b/src/pl/plperl/plperl.control new file mode 100644 index 0000000..3a2230a --- /dev/null +++ b/src/pl/plperl/plperl.control @@ -0,0 +1,8 @@ +# plperl extension +comment = 'PL/Perl procedural language' +default_version = '1.0' +module_pathname = '$libdir/plperl' +relocatable = false +schema = pg_catalog +superuser = true +trusted = true diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h new file mode 100644 index 0000000..a9449d9 --- /dev/null +++ b/src/pl/plperl/plperl.h @@ -0,0 +1,218 @@ +/*------------------------------------------------------------------------- + * + * plperl.h + * Common include file for PL/Perl files + * + * This should be included _AFTER_ postgres.h and system include files + * + * Portions Copyright (c) 1996-2020, PostgreSQL Global Development Group + * Portions Copyright (c) 1995, Regents of the University of California + * + * src/pl/plperl/plperl.h + */ + +#ifndef PL_PERL_H +#define PL_PERL_H + +/* stop perl headers from hijacking stdio and other stuff on Windows */ +#ifdef WIN32 +#define WIN32IO_IS_STDIO +#endif /* WIN32 */ + +/* + * Supply a value of PERL_UNUSED_DECL that will satisfy gcc - the one + * perl itself supplies doesn't seem to. + */ +#define PERL_UNUSED_DECL pg_attribute_unused() + +/* + * Sometimes perl carefully scribbles on our *printf macros. + * So we undefine them here and redefine them after it's done its dirty deed. + */ +#undef vsnprintf +#undef snprintf +#undef vsprintf +#undef sprintf +#undef vfprintf +#undef fprintf +#undef vprintf +#undef printf + +/* + * Perl scribbles on the "_" macro too. + */ +#undef _ + +/* + * ActivePerl 5.18 and later are MinGW-built, and their headers use GCC's + * __inline__. Translate to something MSVC recognizes. Also, perl.h sometimes + * defines isnan, so undefine it here and put back the definition later if + * perl.h doesn't. + */ +#ifdef _MSC_VER +#define __inline__ inline +#ifdef isnan +#undef isnan +#endif +#endif + +/* + * Regarding bool, both PostgreSQL and Perl might use stdbool.h or not, + * depending on configuration. If both agree, things are relatively harmless. + * If not, things get tricky. If PostgreSQL does but Perl does not, define + * HAS_BOOL here so that Perl does not redefine bool; this avoids compiler + * warnings. If PostgreSQL does not but Perl does, we need to undefine bool + * after we include the Perl headers; see below. + */ +#ifdef PG_USE_STDBOOL +#define HAS_BOOL 1 +#endif + + +/* + * Get the basic Perl API. We use PERL_NO_GET_CONTEXT mode so that our code + * can compile against MULTIPLICITY Perl builds without including XSUB.h. + */ +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" + +/* + * We want to include XSUB.h only within .xs files, because on some platforms + * it undesirably redefines a lot of libc functions. But it must appear + * before ppport.h, so use a #define flag to control inclusion here. + */ +#ifdef PG_NEED_PERL_XSUB_H +/* + * On Windows, win32_port.h defines macros for a lot of these same functions. + * To avoid compiler warnings when XSUB.h redefines them, #undef our versions. + */ +#ifdef WIN32 +#undef accept +#undef bind +#undef connect +#undef fopen +#undef kill +#undef listen +#undef lstat +#undef mkdir +#undef open +#undef putenv +#undef recv +#undef rename +#undef select +#undef send +#undef socket +#undef stat +#undef unlink +#endif + +#include "XSUB.h" +#endif + +/* put back our *printf macros ... this must match src/include/port.h */ +#ifdef vsnprintf +#undef vsnprintf +#endif +#ifdef snprintf +#undef snprintf +#endif +#ifdef vsprintf +#undef vsprintf +#endif +#ifdef sprintf +#undef sprintf +#endif +#ifdef vfprintf +#undef vfprintf +#endif +#ifdef fprintf +#undef fprintf +#endif +#ifdef vprintf +#undef vprintf +#endif +#ifdef printf +#undef printf +#endif + +#define vsnprintf pg_vsnprintf +#define snprintf pg_snprintf +#define vsprintf pg_vsprintf +#define sprintf pg_sprintf +#define vfprintf pg_vfprintf +#define fprintf pg_fprintf +#define vprintf pg_vprintf +#define printf(...) pg_printf(__VA_ARGS__) + +/* + * Put back "_" too; but rather than making it just gettext() as the core + * code does, make it dgettext() so that the right things will happen in + * loadable modules (if they've set up TEXTDOMAIN correctly). Note that + * we can't just set TEXTDOMAIN here, because this file is used by more + * extensions than just PL/Perl itself. + */ +#undef _ +#define _(x) dgettext(TEXTDOMAIN, x) + +/* put back the definition of isnan if needed */ +#ifdef _MSC_VER +#ifndef isnan +#define isnan(x) _isnan(x) +#endif +#endif + +/* perl version and platform portability */ +#define NEED_eval_pv +#define NEED_newRV_noinc +#define NEED_sv_2pv_flags +#include "ppport.h" + +/* + * perl might have included stdbool.h. If we also did that earlier (see c.h), + * then that's fine. If not, we probably rejected it for some reason. In + * that case, undef bool and proceed with our own bool. (Note that stdbool.h + * makes bool a macro, but our own replacement is a typedef, so the undef + * makes ours visible again). + */ +#ifndef PG_USE_STDBOOL +#ifdef bool +#undef bool +#endif +#endif + +/* supply HeUTF8 if it's missing - ppport.h doesn't supply it, unfortunately */ +#ifndef HeUTF8 +#define HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ + SvUTF8(HeKEY_sv(he)) : \ + (U32)HeKUTF8(he)) +#endif + +/* supply GvCV_set if it's missing - ppport.h doesn't supply it, unfortunately */ +#ifndef GvCV_set +#define GvCV_set(gv, cv) (GvCV(gv) = cv) +#endif + +/* Perl 5.19.4 changed array indices from I32 to SSize_t */ +#if PERL_BCDVERSION >= 0x5019004 +#define AV_SIZE_MAX SSize_t_MAX +#else +#define AV_SIZE_MAX I32_MAX +#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 *); +SV *plperl_spi_fetchrow(char *); +SV *plperl_spi_prepare(char *, int, SV **); +HV *plperl_spi_exec_prepared(char *, HV *, int, SV **); +SV *plperl_spi_query_prepared(char *, int, SV **); +void plperl_spi_freeplan(char *); +void plperl_spi_cursor_close(char *); +void plperl_spi_commit(void); +void plperl_spi_rollback(void); +char *plperl_sv_to_literal(SV *, char *); +void plperl_util_elog(int level, SV *msg); + +#endif /* PL_PERL_H */ diff --git a/src/pl/plperl/plperl_helpers.h b/src/pl/plperl/plperl_helpers.h new file mode 100644 index 0000000..1e318b6 --- /dev/null +++ b/src/pl/plperl/plperl_helpers.h @@ -0,0 +1,171 @@ +#ifndef PL_PERL_HELPERS_H +#define PL_PERL_HELPERS_H + +#include "mb/pg_wchar.h" + +#include "plperl.h" + + +/* + * convert from utf8 to database encoding + * + * Returns a palloc'ed copy of the original string + */ +static inline char * +utf_u2e(char *utf8_str, size_t len) +{ + char *ret; + + ret = pg_any_to_server(utf8_str, len, PG_UTF8); + + /* ensure we have a copy even if no conversion happened */ + if (ret == utf8_str) + ret = pstrdup(ret); + + return ret; +} + +/* + * convert from database encoding to utf8 + * + * Returns a palloc'ed copy of the original string + */ +static inline char * +utf_e2u(const char *str) +{ + char *ret; + + ret = pg_server_to_any(str, strlen(str), PG_UTF8); + + /* ensure we have a copy even if no conversion happened */ + if (ret == str) + ret = pstrdup(ret); + + return ret; +} + + +/* + * Convert an SV to a char * in the current database encoding + * + * Returns a palloc'ed copy of the original string + */ +static inline char * +sv2cstr(SV *sv) +{ + dTHX; + char *val, + *res; + STRLEN len; + + /* + * get a utf8 encoded char * out of perl. *note* it may not be valid utf8! + */ + + /* + * SvPVutf8() croaks nastily on certain things, like typeglobs and + * readonly objects such as $^V. That's a perl bug - it's not supposed to + * happen. To avoid crashing the backend, we make a copy of the sv before + * passing it to SvPVutf8(). The copy is garbage collected when we're done + * with it. + */ + if (SvREADONLY(sv) || + isGV_with_GP(sv) || + (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM)) + sv = newSVsv(sv); + else + { + /* + * increase the reference count so we can just SvREFCNT_dec() it when + * we are done + */ + SvREFCNT_inc_simple_void(sv); + } + + /* + * Request the string from Perl, in UTF-8 encoding; but if we're in a + * SQL_ASCII database, just request the byte soup without trying to make + * it UTF8, because that might fail. + */ + if (GetDatabaseEncoding() == PG_SQL_ASCII) + val = SvPV(sv, len); + else + val = SvPVutf8(sv, len); + + /* + * Now convert to database encoding. We use perl's length in the event we + * had an embedded null byte to ensure we error out properly. + */ + res = utf_u2e(val, len); + + /* safe now to garbage collect the new SV */ + SvREFCNT_dec(sv); + + return res; +} + +/* + * Create a new SV from a string assumed to be in the current database's + * encoding. + */ +static inline SV * +cstr2sv(const char *str) +{ + dTHX; + SV *sv; + char *utf8_str; + + /* no conversion when SQL_ASCII */ + if (GetDatabaseEncoding() == PG_SQL_ASCII) + return newSVpv(str, 0); + + utf8_str = utf_e2u(str); + + sv = newSVpv(utf8_str, 0); + SvUTF8_on(sv); + pfree(utf8_str); + + return sv; +} + +/* + * croak() with specified message, which is given in the database encoding. + * + * Ideally we'd just write croak("%s", str), but plain croak() does not play + * nice with non-ASCII data. In modern Perl versions we can call cstr2sv() + * and pass the result to croak_sv(); in versions that don't have croak_sv(), + * we have to work harder. + */ +static inline void +croak_cstr(const char *str) +{ + dTHX; + +#ifdef croak_sv + /* Use sv_2mortal() to be sure the transient SV gets freed */ + croak_sv(sv_2mortal(cstr2sv(str))); +#else + + /* + * The older way to do this is to assign a UTF8-marked value to ERRSV and + * then call croak(NULL). But if we leave it to croak() to append the + * error location, it does so too late (only after popping the stack) in + * some Perl versions. Hence, use mess() to create an SV with the error + * location info already appended. + */ + SV *errsv = get_sv("@", GV_ADD); + char *utf8_str = utf_e2u(str); + SV *ssv; + + ssv = mess("%s", utf8_str); + SvUTF8_on(ssv); + + pfree(utf8_str); + + sv_setsv(errsv, ssv); + + croak(NULL); +#endif /* croak_sv */ +} + +#endif /* PL_PERL_HELPERS_H */ diff --git a/src/pl/plperl/plperl_opmask.pl b/src/pl/plperl/plperl_opmask.pl new file mode 100644 index 0000000..3b33112 --- /dev/null +++ b/src/pl/plperl/plperl_opmask.pl @@ -0,0 +1,63 @@ +#!perl + +use strict; +use warnings; + +use Opcode qw(opset opset_to_ops opdesc); + +my $plperl_opmask_h = shift + or die "Usage: $0 <output_filename.h>\n"; + +my $plperl_opmask_tmp = $plperl_opmask_h . "tmp"; +END { unlink $plperl_opmask_tmp } + +open my $fh, ">", "$plperl_opmask_tmp" + or die "Could not write to $plperl_opmask_tmp: $!"; + +printf $fh "#define PLPERL_SET_OPMASK(opmask) \\\n"; +printf $fh " memset(opmask, 1, MAXO);\t/* disable all */ \\\n"; +printf $fh " /* then allow some... */ \\\n"; + +my @allowed_ops = ( + + # basic set of opcodes + qw[:default :base_math !:base_io sort time], + + # require is safe because we redirect the opcode + # entereval is safe as the opmask is now permanently set + # caller is safe because the entire interpreter is locked down + qw[require entereval caller], + + # These are needed for utf8_heavy.pl: + # dofile is safe because we redirect the opcode like require above + # print is safe because the only writable filehandles are STDOUT & STDERR + # prtf (printf) is safe as it's the same as print + sprintf + qw[dofile print prtf], + + # Disallow these opcodes that are in the :base_orig optag + # (included in :default) but aren't considered sufficiently safe + qw[!dbmopen !setpgrp !setpriority], + + # custom is not deemed a likely security risk as it can't be generated from + # perl so would only be seen if the DBA had chosen to load a module that + # used it. Even then it's unlikely to be seen because it's typically + # generated by compiler plugins that operate after PL_op_mask checks. + # But we err on the side of caution and disable it + qw[!custom],); + +printf $fh " /* ALLOWED: @allowed_ops */ \\\n"; + +foreach my $opname (opset_to_ops(opset(@allowed_ops))) +{ + printf $fh qq{ opmask[OP_%-12s] = 0;\t/* %s */ \\\n}, + uc($opname), opdesc($opname); +} +printf $fh " /* end */ \n"; + +close $fh + or die "Error closing $plperl_opmask_tmp: $!"; + +rename $plperl_opmask_tmp, $plperl_opmask_h + or die "Error renaming $plperl_opmask_tmp to $plperl_opmask_h: $!"; + +exit 0; diff --git a/src/pl/plperl/plperlu--1.0.sql b/src/pl/plperl/plperlu--1.0.sql new file mode 100644 index 0000000..10d7594 --- /dev/null +++ b/src/pl/plperl/plperlu--1.0.sql @@ -0,0 +1,17 @@ +/* src/pl/plperl/plperlu--1.0.sql */ + +CREATE FUNCTION plperlu_call_handler() RETURNS language_handler + LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE FUNCTION plperlu_inline_handler(internal) RETURNS void + STRICT LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE FUNCTION plperlu_validator(oid) RETURNS void + STRICT LANGUAGE c AS 'MODULE_PATHNAME'; + +CREATE LANGUAGE plperlu + HANDLER plperlu_call_handler + INLINE plperlu_inline_handler + VALIDATOR plperlu_validator; + +COMMENT ON LANGUAGE plperlu IS 'PL/PerlU untrusted procedural language'; diff --git a/src/pl/plperl/plperlu.control b/src/pl/plperl/plperlu.control new file mode 100644 index 0000000..69473ca --- /dev/null +++ b/src/pl/plperl/plperlu.control @@ -0,0 +1,7 @@ +# plperlu extension +comment = 'PL/PerlU untrusted procedural language' +default_version = '1.0' +module_pathname = '$libdir/plperl' +relocatable = false +schema = pg_catalog +superuser = true diff --git a/src/pl/plperl/po/cs.po b/src/pl/plperl/po/cs.po new file mode 100644 index 0000000..0bded74 --- /dev/null +++ b/src/pl/plperl/po/cs.po @@ -0,0 +1,227 @@ +# Czech message translation file for plperl +# Copyright (C) 2012 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# +# Tomáš Vondra <tv@fuzzy.cz>, 2012, 2013. +msgid "" +msgstr "" +"Project-Id-Version: plperl-cs (PostgreSQL 9.3)\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-09-27 08:08+0000\n" +"PO-Revision-Date: 2019-09-27 20:57+0200\n" +"Last-Translator: Tomas Vondra <tv@fuzzy.cz>\n" +"Language-Team: Czech <info@cspug.cx>\n" +"Language: cs\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: Poedit 2.2.3\n" + +#: plperl.c:406 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Pokud je true, trusted a untrusted Perl kód bude zkompilován ve striktním módu." + +#: plperl.c:420 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Perl inicializační kód spouštěný při inicializaci Perl interpreteru." + +#: plperl.c:442 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Perl inicializační kód spouštěný při prvním použití jazyka plperl." + +#: plperl.c:450 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Perl inicializační kód spouštěný při prvním použití jazyka plperlu." + +#: plperl.c:647 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "na této platformě nelze alokovat více Perl interpreterů" + +#: plperl.c:670 plperl.c:854 plperl.c:860 plperl.c:977 plperl.c:989 +#: plperl.c:1032 plperl.c:1055 plperl.c:2154 plperl.c:2264 plperl.c:2332 +#: plperl.c:2395 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:671 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "během spouštění PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:855 +#, c-format +msgid "while parsing Perl initialization" +msgstr "během parsování Perl inicializace" + +#: plperl.c:861 +#, c-format +msgid "while running Perl initialization" +msgstr "během běhu Perl inicializace" + +#: plperl.c:978 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "během spouštění PLC_TRUSTED" + +#: plperl.c:990 +#, c-format +msgid "while executing utf8fix" +msgstr "během spouštění utf8fix" + +#: plperl.c:1033 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "během spouštění plperl.on_plperl_init" + +#: plperl.c:1056 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "během spouštění plperl.on_plperlu_init" + +#: plperl.c:1102 plperl.c:1793 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl hash obsahuje neexistující sloupec \"%s\"" + +#: plperl.c:1107 plperl.c:1798 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "nelze nastavit systémový atribut \"%s\"" + +#: plperl.c:1195 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "počet rozměrů pole (%d) překračuje povolené maximum (%d)" + +#: plperl.c:1207 plperl.c:1224 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "vícerozměrná pole musí mít výrazy s odpovídajícími rozměry" + +#: plperl.c:1260 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "Perlové pole nelze převést na typ %s který není pole" + +#: plperl.c:1363 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "Perlový hash nelze převést na nekompozitní typ %s" + +#: plperl.c:1385 plperl.c:3306 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "funkce vracející záznam byla zavolána z kontextu, který neumožňuje přijetí záznamu" + +#: plperl.c:1444 +#, c-format +msgid "lookup failed for type %s" +msgstr "vyhledávání selhalo pro typ %s" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} neexistuje" + +#: plperl.c:1772 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} není odkaz na hash" + +#: plperl.c:1803 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "nelze přiřazovat do generovaného sloupce \"%s\"" + +#: plperl.c:2029 plperl.c:2871 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl funkce nemohou vracet datový typ %s" + +#: plperl.c:2042 plperl.c:2912 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl funkce nemohou přijímat datový typ %s" + +#: plperl.c:2159 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "z kompilované funkce se nepodařilo získat CODE referenci \"%s\"" + +#: plperl.c:2252 +#, c-format +msgid "didn't get a return item from function" +msgstr "z funkce nebyla získána návratová hodnota" + +#: plperl.c:2296 plperl.c:2363 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "nelze načíst $_TD" + +#: plperl.c:2320 plperl.c:2383 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "z triggeru nebyla získána návratová hodnota" + +#: plperl.c:2444 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "funkce vracející tabulku (set-valued) byla zavolána z kontextu, který neumožňuje přijetí tabulky" + +#: plperl.c:2489 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "PL/Perl funkce vracející tabulku (set-returned) musí vracet odkaz na pole nebo používat return_next." + +#: plperl.c:2610 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ignoruje modifikovaný řádek v DELETE triggeru" + +#: plperl.c:2618 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "výsledek PL/Perl trigger funkce musí být undef, \"SKIP\", nebo \"MODIFY\"" + +#: plperl.c:2866 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "funkce pro obsluhu triggerů mohou být volané pouze prostřednictvím triggerů" + +#: plperl.c:3213 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "výsledek dotazu má příliš mnoho řádek pro uložení do pole v Perlu" + +#: plperl.c:3283 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "return_next nelze použít v non-SETOF funkci (funkci nevracející tabulku)" + +#: plperl.c:3357 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "PL/Perl funkce vracející tabulku složených typů (SETOF-composite-returning) musí volat return_next s odkazem na hash" + +#: plperl.c:4132 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl funkce \"%s\"" + +#: plperl.c:4144 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "kompilace PL/Perl funkce \"%s\"" + +#: plperl.c:4153 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "PL/Perl anonymní blok kódu" + +#~ msgid "out of memory" +#~ msgstr "paměť vyčerpána" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "PL/Perl funkce musí vracet odkaz na hash nebo pole" diff --git a/src/pl/plperl/po/de.po b/src/pl/plperl/po/de.po new file mode 100644 index 0000000..ba33d41 --- /dev/null +++ b/src/pl/plperl/po/de.po @@ -0,0 +1,222 @@ +# German message translation file for plperl +# Copyright (C) 2019 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# Peter Eisentraut <peter@eisentraut.org>, 2009 - 2019. +# +# Use these quotes: »%s« +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 12\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-05-08 08:08+0000\n" +"PO-Revision-Date: 2019-05-08 10:45+0200\n" +"Last-Translator: Peter Eisentraut <peter@eisentraut.org>\n" +"Language-Team: German <pgsql-translators@postgresql.org>\n" +"Language: de\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#: plperl.c:409 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Wenn wahr, dann wird vertrauenswürdiger und nicht vertrauenswürdiger Perl-Code im »strict«-Modus kompiliert." + +#: plperl.c:423 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Perl-Initialisierungscode, der ausgeführt wird, wenn der Perl-Interpreter initialisiert wird." + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Perl-Initialisierungscode, der ausgeführt wird, wenn plperl zum ersten Mal benutzt wird." + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Perl-Initialisierungscode, der ausgeführt wird, wenn plperlu zum ersten Mal benutzt wird." + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "auf dieser Plattform können nicht mehrere Perl-Interpreter angelegt werden" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2157 plperl.c:2267 plperl.c:2335 +#: plperl.c:2398 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "beim Ausführen von PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "beim Parsen der Perl-Initialisierung" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "beim Ausführen der Perl-Initialisierung" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "beim Ausführen von PLC_TRUSTED" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "beim Ausführen von utf8fix" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "beim Ausführen von plperl.on_plperl_init" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "beim Ausführen von plperl.on_plperlu_init" + +#: plperl.c:1105 plperl.c:1796 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl-Hash enthält nicht existierende Spalte »%s«" + +#: plperl.c:1110 plperl.c:1801 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "Systemattribut »%s« kann nicht gesetzt werden" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "Anzahl der Arraydimensionen (%d) überschreitet erlaubtes Maximum (%d)" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "mehrdimensionale Arrays müssen Arraysausdrücke mit gleicher Anzahl Dimensionen haben" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "kann Perl-Array nicht in Nicht-Array-Typ %s umwandeln" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "kann Perl-Hash nicht in nicht zusammengesetzten Typ %s umwandeln" + +#: plperl.c:1388 plperl.c:3309 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "Funktion, die einen Record zurückgibt, in einem Zusammenhang aufgerufen, der Typ record nicht verarbeiten kann" + +#: plperl.c:1447 +#, c-format +msgid "lookup failed for type %s" +msgstr "Nachschlagen nach Typ %s fehlgeschlagen" + +#: plperl.c:1771 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} existiert nicht" + +#: plperl.c:1775 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} ist keine Hash-Referenz" + +#: plperl.c:1806 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "kann generierte Spalte »%s« nicht setzen" + +#: plperl.c:2032 plperl.c:2874 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl-Funktionen können keinen Rückgabetyp %s haben" + +#: plperl.c:2045 plperl.c:2915 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl-Funktionen können Typ %s nicht annehmen" + +#: plperl.c:2162 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "keine CODE-Referenz erhalten beim Kompilieren von Funktion »%s«" + +#: plperl.c:2255 +#, c-format +msgid "didn't get a return item from function" +msgstr "keinen Rückgabewert aus Funktion erhalten" + +#: plperl.c:2299 plperl.c:2366 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "konnte $_TD nicht auslesen" + +#: plperl.c:2323 plperl.c:2386 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "keinen Rückgabewert aus Triggerfunktion erhalten" + +#: plperl.c:2447 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "Funktion mit Mengenergebnis in einem Zusammenhang aufgerufen, der keine Mengenergebnisse verarbeiten kann" + +#: plperl.c:2492 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "PL/Perl-Funktionen mit Mengenergebnis müssen eine Referenz auf ein Array zurückgeben oder return_next verwenden" + +#: plperl.c:2613 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "geänderte Zeile im DELETE-Trigger wird ignoriert" + +#: plperl.c:2621 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "Ergebnis einer PL/Perl-Triggerfunktion muss undef, »SKIP« oder »MODIFY« sein" + +#: plperl.c:2869 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "Triggerfunktionen können nur als Trigger aufgerufen werden" + +#: plperl.c:3216 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "Anfrageergebnis hat zu viele Zeilen, um in ein Perl-Array zu passen" + +#: plperl.c:3286 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "return_next kann nur in einer Funktion mit SETOF-Rückgabetyp verwendet werden" + +#: plperl.c:3360 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "PL/Perl-Funktion, die SETOF eines zusammengesetzten Typs zurückgibt, muss return_next mit einer Referenz auf ein Hash aufrufen" + +#: plperl.c:4135 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl-Funktion »%s«" + +#: plperl.c:4147 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "Kompilierung der PL/Perl-Funktion »%s«" + +#: plperl.c:4156 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "anonymer PL/Perl-Codeblock" diff --git a/src/pl/plperl/po/es.po b/src/pl/plperl/po/es.po new file mode 100644 index 0000000..7d75fec --- /dev/null +++ b/src/pl/plperl/po/es.po @@ -0,0 +1,224 @@ +# Spanish message translation file for plperl +# +# Copyright (c) 2008-2019, PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# +# Emanuel Calvo Franco <postgres.arg@gmail.com>, 2008. +# Alvaro Herrera <alvherre@alvh.no-ip.org>, 2009-2012 +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL) 12\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2020-09-13 10:38+0000\n" +"PO-Revision-Date: 2019-06-06 17:25-0400\n" +"Last-Translator: Carlos Chapi <carlos.chapi@2ndquadrant.com>\n" +"Language-Team: PgSQL-es-Ayuda <pgsql-es-ayuda@lists.postgresql.org>\n" +"Language: es\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: Poedit 1.8.7\n" + +#: plperl.c:405 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Si es verdadero, se compilará código Perl confiable y no confiable en modo «strict»." + +#: plperl.c:419 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Código Perl de inicialización a ejecutar cuando un intérprete Perl es inicializado." + +#: plperl.c:441 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Código Perl de inicialización a ejecutar cuando plperl se usa por primera vez." + +#: plperl.c:449 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Código Perl de inicialización a ejecutar cuando plperlu se usa por primera vez." + +#: plperl.c:646 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "no se pueden instanciar múltiples intérpretes Perl en esta plataforma" + +#: plperl.c:669 plperl.c:853 plperl.c:859 plperl.c:976 plperl.c:988 +#: plperl.c:1031 plperl.c:1054 plperl.c:2136 plperl.c:2244 plperl.c:2312 +#: plperl.c:2375 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:670 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "mientras se ejecutaba PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:854 +#, c-format +msgid "while parsing Perl initialization" +msgstr "mientras se interpretaba la inicialización de Perl" + +#: plperl.c:860 +#, c-format +msgid "while running Perl initialization" +msgstr "mientras se ejecutaba la inicialización de Perl" + +#: plperl.c:977 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "mientras se ejecutaba PLC_TRUSTED" + +#: plperl.c:989 +#, c-format +msgid "while executing utf8fix" +msgstr "mientras se ejecutaba utf8fix" + +#: plperl.c:1032 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "mientras se ejecutaba plperl.on_plperl_init" + +#: plperl.c:1055 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "mientras se ejecutaba plperl.on_plperlu_init" + +#: plperl.c:1101 plperl.c:1789 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "el hash de Perl contiene el columna inexistente «%s»" + +#: plperl.c:1106 plperl.c:1794 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "no se puede definir el atributo de sistema «%s»" + +#: plperl.c:1194 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "el número de dimensiones del array (%d) excede el máximo permitido (%d)" + +#: plperl.c:1206 plperl.c:1223 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "los arrays multidimensionales deben tener expresiones de arrays con dimensiones coincidentes" + +#: plperl.c:1259 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "no se puede convertir un array de Perl al tipo no-array %s" + +#: plperl.c:1362 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "no se puede convertir un hash de Perl al tipo no compuesto %s" + +#: plperl.c:1384 plperl.c:3284 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "se llamó una función que retorna un registro en un contexto que no puede aceptarlo" + +#: plperl.c:1443 +#, c-format +msgid "lookup failed for type %s" +msgstr "búsqueda del tipo %s falló" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} no existe" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} no es una referencia a un hash" + +#: plperl.c:1799 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "no se puede definir la columna generada «%s»" + +#: plperl.c:2011 plperl.c:2849 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "las funciones en PL/Perl no pueden retornar el tipo %s" + +#: plperl.c:2024 plperl.c:2890 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "funciones de PL/Perl no pueden aceptar el tipo %s" + +#: plperl.c:2141 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "no se obtuvo una referencia CODE en la compilación de la función «%s»" + +#: plperl.c:2232 +#, c-format +msgid "didn't get a return item from function" +msgstr "no se obtuvo un elemento de retorno desde la función" + +#: plperl.c:2276 plperl.c:2343 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "no se pudo obtener $_TD" + +#: plperl.c:2300 plperl.c:2363 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "no se obtuvo un elemento de retorno desde la función de disparador" + +#: plperl.c:2422 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "se llamó a una función que retorna un conjunto en un contexto que no puede aceptarlo" + +#: plperl.c:2467 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "una función PL/Perl que retorna un conjunto debe retornar una referencia a un array o usar return_next" + +#: plperl.c:2588 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ignorando la tupla modificada en el disparador DELETE" + +#: plperl.c:2596 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "el resultado de la función disparadora en PL/Perl debe ser undef, «SKIP» o «MODIFY»" + +#: plperl.c:2844 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "las funciones disparadoras sólo pueden ser llamadas como disparadores" + +#: plperl.c:3191 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "el resultado de la consulta tiene demasiados registros y no entran en un array de Perl" + +#: plperl.c:3261 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "no se puede utilizar return_next en una función sin SETOF" + +#: plperl.c:3335 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "una función Perl que retorna SETOF de un tipo compuesto debe invocar return_next con una referencia a un hash" + +#: plperl.c:4110 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "función PL/Perl «%s»" + +#: plperl.c:4122 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "compilación de la función PL/Perl «%s»" + +#: plperl.c:4131 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "bloque de código anónimo de PL/Perl" diff --git a/src/pl/plperl/po/fr.po b/src/pl/plperl/po/fr.po new file mode 100644 index 0000000..d34cac6 --- /dev/null +++ b/src/pl/plperl/po/fr.po @@ -0,0 +1,279 @@ +# translation of plperl.po to fr_fr +# french message translation file for plperl +# +# Use these quotes: « %s » +# Guillaume Lelarge <guillaume@lelarge.info>, 2009. +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 12\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-05-17 01:08+0000\n" +"PO-Revision-Date: 2019-05-17 15:02+0200\n" +"Last-Translator: Guillaume Lelarge <guillaume@lelarge.info>\n" +"Language-Team: French <guillaume@lelarge.info>\n" +"Language: fr\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: Poedit 2.2.1\n" + +#: plperl.c:409 +msgid "" +"If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "" +"Si true, le code Perl de confiance et sans confiance sera compilé en mode\n" +"strict." + +#: plperl.c:423 +msgid "" +"Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "" +"Code d'initialisation Perl à exécuter lorsque un interpréteur Perl est\n" +"initialisé." + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "" +"Code d'initialisation Perl à exécuter lorsque plperl est utilisé pour la\n" +"première fois" + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "" +"Code d'initialisation Perl à exécuter lorsque plperlu est utilisé pour la\n" +"première fois" + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "ne peut pas allouer plusieurs interpréteurs Perl sur cette plateforme" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2157 plperl.c:2267 plperl.c:2335 +#: plperl.c:2398 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "lors de l'exécution de PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "lors de l'analyse de l'initialisation de perl" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "lors de l'exécution de l'initialisation de perl" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "lors de l'exécution de PLC_TRUSTED" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "lors de l'exécution de utf8fix" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "lors de l'exécution de plperl.on_plperl_init" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "lors de l'exécution de plperl.on_plperlu_init" + +#: plperl.c:1105 plperl.c:1796 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Le hachage Perl contient la colonne « %s » inexistante" + +#: plperl.c:1110 plperl.c:1801 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "ne peut pas initialiser l'attribut système « %s »" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "" +"le nombre de dimensions du tableau (%d) dépasse la maximum autorisé (%d)" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "" +"multidimensional arrays must have array expressions with matching dimensions" +msgstr "" +"les tableaux multidimensionnels doivent avoir des expressions de tableaux\n" +"avec les dimensions correspondantes" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "" +"ne peut pas convertir le tableau Perl en un type %s qui n'est pas un tableau" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "ne peut pas convertir le hachage Perl en un type %s non composite" + +#: plperl.c:1388 plperl.c:3309 +#, c-format +msgid "" +"function returning record called in context that cannot accept type record" +msgstr "" +"fonction renvoyant le type record appelée dans un contexte qui ne peut pas\n" +"accepter le type record" + +#: plperl.c:1447 +#, c-format +msgid "lookup failed for type %s" +msgstr "recherche échouée pour le type %s" + +#: plperl.c:1771 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} n'existe pas" + +#: plperl.c:1775 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} n'est pas une référence de hachage" + +#: plperl.c:1806 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "ne peut pas initialiser la colonne générée « %s »" + +#: plperl.c:2032 plperl.c:2874 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "Les fonctions PL/perl ne peuvent pas renvoyer le type %s" + +#: plperl.c:2045 plperl.c:2915 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "Les fonctions PL/perl ne peuvent pas accepter le type %s" + +#: plperl.c:2162 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "" +"n'a pas obtenu une référence CODE lors de la compilation de la fonction « %s " +"»" + +#: plperl.c:2255 +#, c-format +msgid "didn't get a return item from function" +msgstr "n'a pas obtenu un élément en retour de la fonction" + +#: plperl.c:2299 plperl.c:2366 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "n'a pas pu récupérer $_TD" + +#: plperl.c:2323 plperl.c:2386 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "n'a pas obtenu un élément en retour de la fonction trigger" + +#: plperl.c:2447 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "" +"fonction renvoyant un ensemble appelée dans un contexte qui ne peut pas\n" +"accepter un ensemble" + +#: plperl.c:2492 +#, c-format +msgid "" +"set-returning PL/Perl function must return reference to array or use " +"return_next" +msgstr "" +"la fonction PL/perl renvoyant des ensembles doit renvoyer la référence à\n" +"un tableau ou utiliser return_next" + +#: plperl.c:2613 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ignore la ligne modifiée dans le trigger DELETE" + +#: plperl.c:2621 +#, c-format +msgid "" +"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "" +"le résultat de la fonction trigger PL/perl doit être undef, « SKIP » ou\n" +"« MODIFY »" + +#: plperl.c:2869 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "les fonctions trigger peuvent seulement être appelées par des triggers" + +#: plperl.c:3216 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "" +"le résultat de la requête contient trop de lignes pour être intégré dans un " +"tableau Perl" + +#: plperl.c:3286 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "ne peut pas utiliser return_next dans une fonction non SETOF" + +#: plperl.c:3360 +#, c-format +msgid "" +"SETOF-composite-returning PL/Perl function must call return_next with " +"reference to hash" +msgstr "" +"une fonction PL/perl renvoyant des lignes composites doit appeler\n" +"return_next avec la référence à un hachage" + +#: plperl.c:4135 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "fonction PL/Perl « %s »" + +#: plperl.c:4147 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "compilation de la fonction PL/Perl « %s »" + +#: plperl.c:4156 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "bloc de code PL/Perl anonyme" + +#~ msgid "out of memory" +#~ msgstr "mémoire épuisée" + +#~ msgid "composite-returning PL/Perl function must return reference to hash" +#~ msgstr "" +#~ "la fonction PL/perl renvoyant des valeurs composites doit renvoyer la\n" +#~ "référence à un hachage" + +#~ msgid "while executing PLC_SAFE_OK" +#~ msgstr "lors de l'exécution de PLC_SAFE_OK" + +#~ msgid "creation of Perl function \"%s\" failed: %s" +#~ msgstr "échec de la création de la fonction Perl « %s » : %s" + +#~ msgid "error from Perl function \"%s\": %s" +#~ msgstr "échec dans la fonction Perl « %s » : %s" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "" +#~ "la fonction PL/perl doit renvoyer la référence à un hachage ou à un " +#~ "tableau" diff --git a/src/pl/plperl/po/it.po b/src/pl/plperl/po/it.po new file mode 100644 index 0000000..359817d --- /dev/null +++ b/src/pl/plperl/po/it.po @@ -0,0 +1,228 @@ +# +# plperl.po +# Italian message translation file for plperl +# +# For development and bug report please use: +# https://github.com/dvarrazzo/postgresql-it +# +# Copyright (C) 2012-2017 PostgreSQL Global Development Group +# Copyright (C) 2010, Associazione Culturale ITPUG +# +# Daniele Varrazzo <daniele.varrazzo@gmail.com>, 2012-2017. +# Emanuele Zamprogno <emanuele.zamprogno@itpug.org> +# +# This file is distributed under the same license as the PostgreSQL package. +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL) 11\n" +"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" +"POT-Creation-Date: 2018-10-08 14:08+0000\n" +"PO-Revision-Date: 2017-04-23 04:42+0100\n" +"Last-Translator: Daniele Varrazzo <daniele.varrazzo@gmail.com>\n" +"Language-Team: https://github.com/dvarrazzo/postgresql-it\n" +"Language: it\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Poedit-SourceCharset: utf-8\n" +"Plural-Forms: nplurals=2; plural=n != 1;\n" +"X-Generator: Poedit 1.8.7.1\n" + +#: plperl.c:409 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Se vero, il codice Perl affidabile e non affidabile sarà compilato in modalità strict." + +#: plperl.c:423 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "codice Perl di inizializzazione da eseguire quando l'interprete Perl è inizializzato." + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "codice Perl di inizializzazione da eseguire una sola volta quando plperl è usato per la prima volta." + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "codice Perl di inizializzazione da eseguire una sola volta quando plperlu è usato per la prima volta." + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "non è possibile allocare piû interpreti Perl su questa piattaforma" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2143 plperl.c:2253 plperl.c:2321 +#: plperl.c:2384 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "nell'esecuzione di PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "durante il parsing dell'inizializzazione Perl" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "durante l'esecuzione dell'inizializzazione Perl" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "nell'esecuzione di PLC_TRUSTED" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "durante l'esecuzione di utf8fix" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "nell'esecuzione di plperl.on_plperl_init" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "nell'esecuzione di plperl.on_plperlu_init" + +#: plperl.c:1105 plperl.c:1787 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "La struttura hash in Perl contiene la colonna inesistente \"%s\"" + +#: plperl.c:1110 plperl.c:1792 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "l'attributo di sistema \"%s\" non si può impostare" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "il numero di dimensioni dell'array (%d) eccede il massimo consentito (%d)" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "gli array multidimensionali devono avere espressioni array di dimensioni corrispondenti" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "non è possibile convertire un array Perl nel tipo non-array %s" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "non è possibile convertire un hash Perl nel tipo non composito %s" + +#: plperl.c:1388 plperl.c:3288 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "la funzione che restituisce un record è chiamata in un contesto che non può accettare il tipo record" + +#: plperl.c:1447 +#, c-format +msgid "lookup failed for type %s" +msgstr "ricerca del tipo %s fallita" + +#: plperl.c:1762 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} non esiste" + +#: plperl.c:1766 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} non è un riferimento ad un hash" + +#: plperl.c:2018 plperl.c:2860 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "la funzione PL/Perl non può restituire il tipo %s" + +#: plperl.c:2031 plperl.c:2901 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "la funzione PL/Perl non può accettare il tipo %s" + +#: plperl.c:2148 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "non ho ricevuto un riferimento CODE dal compilare la funzione \"%s\"" + +#: plperl.c:2241 +#, c-format +msgid "didn't get a return item from function" +msgstr "la funzione non ha restituito un elemento" + +#: plperl.c:2285 plperl.c:2352 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "lettura di $_TD fallita" + +#: plperl.c:2309 plperl.c:2372 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "la funzione trigger non ha restituito un elemento" + +#: plperl.c:2433 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "la funzione che restituisce insiemi è chiamata in un contesto che non può accettare un insieme" + +#: plperl.c:2478 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "la funzione PL/Perl che restituisce un insieme deve restituire un riferimento ad un array o usare return_next" + +#: plperl.c:2599 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "modifiche alla riga ignorate nel trigger DELETE" + +#: plperl.c:2607 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "il risultato della funzione trigger PL/Perl deve essere undef, \"SKIP\" oppure \"MODIFY\"" + +#: plperl.c:2855 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "le funzioni trigger possono essere chiamate esclusivamente da trigger" + +#: plperl.c:3195 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "il risultato della query ha troppe righe per un array Perl" + +#: plperl.c:3265 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "non si può usare return_next in una funzione non-SETOF" + +#: plperl.c:3339 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "una funzione PL/Perl che restituisce SETOF di un tipo composito deve chiamare return_next con riferimento ad un hash" + +#: plperl.c:4117 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "funzione PL/Perl \"%s\"" + +#: plperl.c:4129 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "compilazione della funzione Perl \"%s\"" + +#: plperl.c:4138 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "blocco di codice anonimo PL/Perl" diff --git a/src/pl/plperl/po/ja.po b/src/pl/plperl/po/ja.po new file mode 100644 index 0000000..aaf8015 --- /dev/null +++ b/src/pl/plperl/po/ja.po @@ -0,0 +1,246 @@ +# Japanese message translation file for plperl +# Copyright (C) 2019 PostgreSQL Global Development Group +# This file is distributed under the same license as the pg_archivecleanup (PostgreSQL) package. +# Honda Shigehiro <honda@postgresql.jp>, 2012 +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL 12 beta 1)\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-06-11 11:34+0900\n" +"PO-Revision-Date: 2019-06-11 12:08+0900\n" +"Last-Translator: Kyotaro Horiguchi <horikyota.ntt@gmail.com>\n" +"Language-Team: jpug-doc <jpug-doc@ml.postgresql.jp>\n" +"Language: ja\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=1; plural=0;\n" +"X-Generator: Poedit 1.5.4\n" + +#: plperl.c:406 +msgid "" +"If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "" +"true の場合、trusted および untrusted な Perl のコードはいずれも strict モー" +"ドでコンパイルされます。" + +#: plperl.c:420 +msgid "" +"Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "" +"Perl のインタプリタが初期化される際に実行されるべき Perl の初期化コード。" + +#: plperl.c:442 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "plperl が最初に使用される際に一度だけ実行される Perl の初期化コード。" + +#: plperl.c:450 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "plperlu が最初に使用される際に一度だけ実行される Perl の初期化コード。" + +#: plperl.c:647 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "このプラットフォームでは複数の Perl インタプリタを設定できません" + +#: plperl.c:670 plperl.c:854 plperl.c:860 plperl.c:977 plperl.c:989 +#: plperl.c:1032 plperl.c:1055 plperl.c:2154 plperl.c:2264 plperl.c:2332 +#: plperl.c:2395 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:671 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "PostgreSQL::InServer::SPI::bootstrap の実行中" + +#: plperl.c:855 +#, c-format +msgid "while parsing Perl initialization" +msgstr "Perl 初期化処理のパース中" + +#: plperl.c:861 +#, c-format +msgid "while running Perl initialization" +msgstr "Perl 初期化処理の実行中" + +#: plperl.c:978 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "PLC_TRUSTED の実行中" + +#: plperl.c:990 +#, c-format +msgid "while executing utf8fix" +msgstr "utf8fix の実行中" + +#: plperl.c:1033 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "plperl.on_plperl_init の実行中" + +#: plperl.c:1056 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "plperl.on_plperlu_init の実行中" + +#: plperl.c:1102 plperl.c:1793 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl ハッシュに存在しない列 \"%s\" があります" + +#: plperl.c:1107 plperl.c:1798 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "システム属性 \"%s\" は変更できません" + +#: plperl.c:1195 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "配列の次元数(%d)が制限値(%d)を超えています" + +#: plperl.c:1207 plperl.c:1224 +#, c-format +msgid "" +"multidimensional arrays must have array expressions with matching dimensions" +msgstr "多次元配列は次元数に合った配列式を持たなければなりません" + +#: plperl.c:1260 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "Perl 配列を非配列型 %s に変換できません" + +#: plperl.c:1363 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "Perl ハッシュを非複合型 %s に変換できません" + +#: plperl.c:1385 plperl.c:3306 +#, c-format +msgid "" +"function returning record called in context that cannot accept type record" +msgstr "" +"レコード型を受け付けられないコンテキストでレコードを返す関数が呼び出されまし" +"た" + +#: plperl.c:1444 +#, c-format +msgid "lookup failed for type %s" +msgstr "型 %s の検索に失敗しました" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} は存在しません" + +#: plperl.c:1772 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} はハッシュへの参照ではありません" + +#: plperl.c:1803 +#, c-format +#| msgid "cannot alter inherited column \"%s\"" +msgid "cannot set generated column \"%s\"" +msgstr "生成列\"%s\"は変更できません" + +#: plperl.c:2029 plperl.c:2871 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl 関数は %s 型を返すことができません" + +#: plperl.c:2042 plperl.c:2912 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl 関数は %s 型を受け付けられません" + +#: plperl.c:2159 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "関数 \"%s\" のコンパイルからはコード参照を取得しませんでした" + +#: plperl.c:2252 +#, c-format +msgid "didn't get a return item from function" +msgstr "関数からは戻り項目を取得しませんでした" + +#: plperl.c:2296 plperl.c:2363 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "$_TD を取り出せませんでした" + +#: plperl.c:2320 plperl.c:2383 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "トリガー関数から項目を取得しませんでした" + +#: plperl.c:2444 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "集合を受け付けられないコンテキストで集合値関数が呼ばれました" + +#: plperl.c:2489 +#, c-format +msgid "" +"set-returning PL/Perl function must return reference to array or use " +"return_next" +msgstr "" +"集合を返す PL/Perl 関数は、配列への参照を返すかまたは return_next を使う必要" +"があります" + +#: plperl.c:2610 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "DELETE トリガーで変更された行を無視しています" + +#: plperl.c:2618 +#, c-format +msgid "" +"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "" +"PL/Perl のトリガー関数の結果は undef、\"SKIP\"、\"MODIFY\" のいずれかでなけれ" +"ばなりません" + +#: plperl.c:2866 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "トリガー関数はトリガーとしてのみコールできます" + +#: plperl.c:3213 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "問い合わせの結果に含まれる行数が Perl の配列に対して多すぎます" + +#: plperl.c:3283 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "集合を返す関数以外で return_next を使うことはできません" + +#: plperl.c:3357 +#, c-format +msgid "" +"SETOF-composite-returning PL/Perl function must call return_next with " +"reference to hash" +msgstr "" +"複合型の集合を返す PL/Perl 関数は、ハッシュへの参照を持つ return_next を呼び" +"出さなければなりません" + +#: plperl.c:4132 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl 関数 \"%s\"" + +#: plperl.c:4144 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "PL/Perl 関数 \"%s\" のコンパイル" + +#: plperl.c:4153 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "PL/Perl の無名コードブロック" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "PL/Perl 関数はハッシュまたは配列への参照を返す必要があります" diff --git a/src/pl/plperl/po/ko.po b/src/pl/plperl/po/ko.po new file mode 100644 index 0000000..a512cfe --- /dev/null +++ b/src/pl/plperl/po/ko.po @@ -0,0 +1,237 @@ +# LANGUAGE message translation file for plperl +# Copyright (C) 2016 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# Ioseph Kim <ioseph@uri.sarang.net>, 2016. +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL) 12\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2020-02-09 20:08+0000\n" +"PO-Revision-Date: 2019-11-01 12:51+0900\n" +"Last-Translator: Ioseph Kim <ioseph@uri.sarang.net>\n" +"Language-Team: Korean Team <pgsql-kr@postgresql.kr>\n" +"Language: ko\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#: plperl.c:406 +msgid "" +"If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "true로 지정하면, Perl 코드가 엄격한 구문 검사로 컴파일 됨" + +#: plperl.c:420 +msgid "" +"Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Perl 인터프리터가 초기화 될 때 실행할 Perl 초기화 코드" + +#: plperl.c:442 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "plperl 모듈이 처음 사용될 때 실행할 Perl 초기화 코드" + +#: plperl.c:450 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "plperlu 모듈이 처음 사용될 때 실행할 Perl 초기화 코드" + +#: plperl.c:647 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "이 플랫폼에 여러 Perl 인터프리터를 사용할 수 없음" + +#: plperl.c:670 plperl.c:854 plperl.c:860 plperl.c:977 plperl.c:989 +#: plperl.c:1032 plperl.c:1055 plperl.c:2154 plperl.c:2264 plperl.c:2332 +#: plperl.c:2395 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:671 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "PostgreSQL::InServer::SPI::bootstrap 실행 중" + +#: plperl.c:855 +#, c-format +msgid "while parsing Perl initialization" +msgstr "Perl 초기화 구문 분석 중" + +#: plperl.c:861 +#, c-format +msgid "while running Perl initialization" +msgstr "Perl 초기화 실행 중" + +#: plperl.c:978 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "PLC_TRUSTED 실행 중" + +#: plperl.c:990 +#, c-format +msgid "while executing utf8fix" +msgstr "utf8fix 실행 중" + +#: plperl.c:1033 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "plperl.on_plperl_init 실행 중" + +#: plperl.c:1056 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "plperl.on_plperlu_init 실행 중" + +#: plperl.c:1102 plperl.c:1793 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl 해시에 존재하지 않는 \"%s\" 칼럼이 포함되었습니다" + +#: plperl.c:1107 plperl.c:1798 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "\"%s\" 시스템 속성을 지정할 수 없음" + +#: plperl.c:1195 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "지정한 배열 크기(%d)가 최대치(%d)를 초과했습니다" + +#: plperl.c:1207 plperl.c:1224 +#, c-format +msgid "" +"multidimensional arrays must have array expressions with matching dimensions" +msgstr "다차원 배열에는 일치하는 차원이 포함된 배열 식이 있어야 함" + +#: plperl.c:1260 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "Perl 배열형을 비배열형 %s 자료형으로 변환할 수 없음" + +#: plperl.c:1363 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "Perl 해시 자료형을 비복합 %s 자료형으로 변환할 수 없음" + +#: plperl.c:1385 plperl.c:3306 +#, c-format +msgid "" +"function returning record called in context that cannot accept type record" +msgstr "반환 자료형이 record인데 함수가 그 자료형으로 반환하지 않음" + +#: plperl.c:1444 +#, c-format +msgid "lookup failed for type %s" +msgstr "%s 자료형 찾기 실패" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} 없음" + +#: plperl.c:1772 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} 자료형이 해시 참조가 아님" + +#: plperl.c:1803 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "\"%s\" 계산된 칼럼을 지정할 수 없음" + +#: plperl.c:2029 plperl.c:2871 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl 함수는 %s 자료형을 반환할 수 없음" + +#: plperl.c:2042 plperl.c:2912 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl 함수는 %s 자료형을 사용할 수 없음" + +#: plperl.c:2159 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "\"%s\" 함수를 컴파일 하면서 코드 참조를 구할 수 없음" + +#: plperl.c:2252 +#, c-format +msgid "didn't get a return item from function" +msgstr "함수에서 반환할 항목을 못 찾음" + +#: plperl.c:2296 plperl.c:2363 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "$_TD 못 구함" + +#: plperl.c:2320 plperl.c:2383 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "트리거 함수에서 반환할 항목을 못 찾음" + +#: plperl.c:2444 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "" +"set-values 함수(테이블 리턴 함수)가 set 정의 없이 사용되었습니다 (테이블과 해" +"당 열 alias 지정하세요)" + +#: plperl.c:2489 +#, c-format +msgid "" +"set-returning PL/Perl function must return reference to array or use " +"return_next" +msgstr "집합 반환 PL/Perl 함수는 배열 또는 return_next 를 사용해서 반환해야 함" + +#: plperl.c:2610 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "DELETE 트리거에서는 변경된 로우는 무시 함" + +#: plperl.c:2618 +#, c-format +msgid "" +"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "" +"PL/Perl 트리거 함수의 결과는 undef, \"SKIP\", \"MODIFY\" 중 하나여야 함" + +#: plperl.c:2866 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "트리거 함수는 트리거로만 호출될 수 있음" + +#: plperl.c:3213 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "쿼리 결과가 Perl 배열에 담기에는 너무 많습니다" + +#: plperl.c:3283 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "SETOF 함수가 아닌 경우에는 return_next 구문을 쓸 수 없음" + +#: plperl.c:3357 +#, c-format +msgid "" +"SETOF-composite-returning PL/Perl function must call return_next with " +"reference to hash" +msgstr "" +"SETOF-composite-returning PL/Perl 함수는 return_next 에서 해시 자료형을 참조" +"해야 함" + +#: plperl.c:4132 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "\"%s\" PL/Perl 함수" + +#: plperl.c:4144 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "\"%s\" PL/Perl 함수 컴필레이션" + +#: plperl.c:4153 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "PL/Perl 익명 코드 블럭" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "PL/Perl 함수는 해시나 배열 자료형을 참조하게 반환해야 함" diff --git a/src/pl/plperl/po/pl.po b/src/pl/plperl/po/pl.po new file mode 100644 index 0000000..d0dd146 --- /dev/null +++ b/src/pl/plperl/po/pl.po @@ -0,0 +1,225 @@ +# Polish message translation file for plperl +# Copyright (C) 2011 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# Begina Felicysym <begina.felicysym@wp.eu>, 2011, 2012. +# grzegorz <begina.felicysym@wp.eu>, 2015, 2016. +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL 9.1)\n" +"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" +"POT-Creation-Date: 2017-04-09 21:07+0000\n" +"PO-Revision-Date: 2016-07-03 18:04+0200\n" +"Last-Translator: grzegorz <begina.felicysym@wp.eu>\n" +"Language-Team: begina.felicysym@wp.eu\n" +"Language: pl\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=3; plural=(n==1 ? 0 : n%10>=2 && n%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" +"X-Generator: Virtaal 0.7.1\n" + +#: plperl.c:390 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Jeśli prawda, zaufanych i niezaufanych kod Perl zostanie skompilowany w trybie ścisłym." + +#: plperl.c:404 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Kod inicjujący Perl do wykonania gdy inicjowany jest interpreter Perl." + +#: plperl.c:426 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Kod inicjujący Perl do jednokrotnego wykonania gdy plperl jest użyty po raz pierwszy." + +#: plperl.c:434 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Kod inicjujący Perl do jednokrotnego wykonania gdy plperlu jest użyty po raz pierwszy." + +#: plperl.c:631 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "nie można przydzielić wielu interpreterów Perl na tej platformie" + +#: plperl.c:651 plperl.c:826 plperl.c:832 plperl.c:946 plperl.c:958 +#: plperl.c:1001 plperl.c:1022 plperl.c:2074 plperl.c:2183 plperl.c:2250 +#: plperl.c:2312 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:652 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "podczas wykonania PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:827 +#, c-format +msgid "while parsing Perl initialization" +msgstr "podczas przetwarzania inicjacji Perl" + +#: plperl.c:833 +#, c-format +msgid "while running Perl initialization" +msgstr "podczas wykonywania inicjacji Perl" + +#: plperl.c:947 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "podczas wykonywania PLC_TRUSTED" + +#: plperl.c:959 +#, c-format +msgid "while executing utf8fix" +msgstr "podczas wykonywania utf8fix" + +#: plperl.c:1002 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "podczas wykonania plperl.on_plperl_init" + +#: plperl.c:1023 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "podczas wykonania plperl.on_plperlu_init" + +#: plperl.c:1067 plperl.c:1719 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "hasz Perl zawiera nieistniejącą kolumnę \"%s\"" + +#: plperl.c:1072 plperl.c:1724 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "nie można ustawić atrybutu systemowego \"%s\"" + +#: plperl.c:1157 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "liczba wymiarów tablicy (%d) przekracza maksimum (%d)" + +#: plperl.c:1169 plperl.c:1186 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "wielowymiarowe tablice muszą mieć wyrażenia tablicowe z pasującymi wymiarami" + +#: plperl.c:1221 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "nie można zmienić typu tablicowego Perl na typ nietablicowy %s" + +#: plperl.c:1323 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "nie można przekształcić Perlowego hasza na typ niezłożony %s" + +#: plperl.c:1334 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "funkcja zwracająca rekord w wywołaniu, które nie akceptuje typów złożonych" + +#: plperl.c:1349 +#, c-format +msgid "PL/Perl function must return reference to hash or array" +msgstr "funkcja PL/Perl musi zwracać referencję do hasza lub tablicy" + +#: plperl.c:1386 +#, c-format +msgid "lookup failed for type %s" +msgstr "nie dało się wyszukać typu %s" + +#: plperl.c:1695 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} nie istnieje" + +#: plperl.c:1699 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} nie jest referencją haszu" + +#: plperl.c:1950 plperl.c:2785 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "funkcje PL/Perl nie mogą zwracać wartości typu %s" + +#: plperl.c:1963 plperl.c:2827 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "funkcje PL/Perl nie obsługują typu %s" + +#: plperl.c:2079 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "nie udało się pobrać wskazania CODE z kompilowanej funkcji \"%s\"" + +#: plperl.c:2171 +#, c-format +msgid "didn't get a return item from function" +msgstr "nie odebrano zwracanego elementu z funkcji" + +#: plperl.c:2214 plperl.c:2280 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "nie dało się pobrać $_TD" + +#: plperl.c:2238 plperl.c:2300 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "nie odebrano zwracanego elementu z funkcji wyzwalacza" + +#: plperl.c:2357 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "funkcja zwracająca zbiór rekordów wywołana w kontekście, w którym nie jest to dopuszczalne" + +#: plperl.c:2401 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "funkcja PL/Perl zwracająca zbiór rekordów musi zwracać tablicę lub użyć return_next" + +#: plperl.c:2522 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ignorowanie modyfikacji wiersza w wyzwalaczy DELETE" + +#: plperl.c:2530 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "funkcja wyzwalacza PL/Perl musi zwracać undef, \"SKIP\", lub \"MODIFY\"" + +#: plperl.c:2780 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "procedury wyzwalaczy mogą być wywoływane jedynie przez wyzwalacze" + +#: plperl.c:3120 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "wynik zapytania ma za dużo wierszy by pomieścić w tabeli Perl" + +#: plperl.c:3165 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "nie można używać return_next w funkcji nie SETOF" + +#: plperl.c:3219 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "funkcja PL/Perl zwracająca grupę wartości złożonych musi wywołać return_next z referencją haszu" + +#: plperl.c:3882 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "funkcja PL/Perl \"%s\"" + +#: plperl.c:3894 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "kompilacja funkcji PL/Perl \"%s\"" + +#: plperl.c:3903 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "anonimowy blok kodu PL/Perl" + +#~ msgid "out of memory" +#~ msgstr "brak pamięci" diff --git a/src/pl/plperl/po/pt_BR.po b/src/pl/plperl/po/pt_BR.po new file mode 100644 index 0000000..523cd90 --- /dev/null +++ b/src/pl/plperl/po/pt_BR.po @@ -0,0 +1,222 @@ +# Brazilian Portuguese message translation file for plperl +# +# Copyright (C) 2009-2021 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# +# Euler Taveira <euler@eulerto.com>, 2009-2021. +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 13\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2021-05-09 21:41-0300\n" +"PO-Revision-Date: 2009-05-10 01:12-0300\n" +"Last-Translator: Euler Taveira <euler@eulerto.com>\n" +"Language-Team: Brazilian Portuguese <pgsql-translators@postgresql.org>\n" +"Language: pt_BR\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#: plperl.c:405 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Se verdadeiro, código Perl confiável e não-confiável será compilado em modo estrito." + +#: plperl.c:419 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Código de inicialização Perl executado quando um interpretador Perl for inicializado." + +#: plperl.c:441 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Código de inicialização Perl executado quando plperl for utilizado pela primeira vez." + +#: plperl.c:449 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Código de inicialização Perl executado quando plperlu for utilizado pela primeira vez." + +#: plperl.c:646 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "não pode alocar múltiplos interpretadores Perl nessa plataforma" + +#: plperl.c:669 plperl.c:853 plperl.c:859 plperl.c:976 plperl.c:988 +#: plperl.c:1031 plperl.c:1054 plperl.c:2136 plperl.c:2244 plperl.c:2312 +#: plperl.c:2375 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:670 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "ao executar PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:854 +#, c-format +msgid "while parsing Perl initialization" +msgstr "ao analisar código de inicialização Perl" + +#: plperl.c:860 +#, c-format +msgid "while running Perl initialization" +msgstr "ao executar código de inicialização Perl" + +#: plperl.c:977 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "ao executar PLC_TRUSTED" + +#: plperl.c:989 +#, c-format +msgid "while executing utf8fix" +msgstr "ao executar utf8fix" + +#: plperl.c:1032 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "ao executar plperl.on_plperl_init" + +#: plperl.c:1055 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "ao executar plperl.on_plperlu_init" + +#: plperl.c:1101 plperl.c:1789 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "hash Perl contém coluna inexistente \"%s\"" + +#: plperl.c:1106 plperl.c:1794 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "não pode definir atributo do sistema \"%s\"" + +#: plperl.c:1194 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "número de dimensões da matriz (%d) excede o máximo permitido (%d)" + +#: plperl.c:1206 plperl.c:1223 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "matrizes multidimensionais devem ter expressões de matriz com dimensões correspondentes" + +#: plperl.c:1259 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "não pode converter array Perl para tipo que não é array %s" + +#: plperl.c:1362 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "não pode converter hash Perl para tipo não-composto %s" + +#: plperl.c:1384 plperl.c:3284 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "função que retorna record foi chamada em um contexto que não pode aceitar tipo record" + +#: plperl.c:1443 +#, c-format +msgid "lookup failed for type %s" +msgstr "falhou ao pesquisar por tipo %s" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} não existe" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} não é uma referência hash" + +#: plperl.c:1799 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "não pode definir coluna gerada \"%s\"" + +#: plperl.c:2011 plperl.c:2849 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "funções PL/Perl não podem retornar tipo %s" + +#: plperl.c:2024 plperl.c:2890 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "funções PL/Perl não podem aceitar tipo %s" + +#: plperl.c:2141 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "não obteve uma referência CODE da compilação da função \"%s\"" + +#: plperl.c:2232 +#, c-format +msgid "didn't get a return item from function" +msgstr "não obteve um item de retorno da função" + +#: plperl.c:2276 plperl.c:2343 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "não pôde obter $_TD" + +#: plperl.c:2300 plperl.c:2363 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "não obteve um item de retorno da função de gatilho" + +#: plperl.c:2422 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "função que tem argumento do tipo conjunto foi chamada em um contexto que não pode aceitar um conjunto" + +#: plperl.c:2467 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "funçao PL/Perl que retorna conjunto deve retornar referência para matriz ou usar return_next" + +#: plperl.c:2588 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ignorando registro modificado em gatilho DELETE" + +#: plperl.c:2596 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "resultado da função de gatilho PL/Perl deve ser undef, \"SKIP\" ou \"MODIFY\"" + +#: plperl.c:2844 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "funções de gatilho só podem ser chamadas como gatilhos" + +#: plperl.c:3191 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "resultado da consulta tem muitos registros para caber em um array Perl" + +#: plperl.c:3261 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "não pode utilizar return_next em uma função que não retorna conjunto" + +#: plperl.c:3335 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "função PL/Perl que retorna um conjunto de tipo composto deve chamar return_next com referência a um hash" + +#: plperl.c:4110 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "função PL/Perl \"%s\"" + +#: plperl.c:4122 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "compilação da função PL/Perl \"%s\"" + +#: plperl.c:4131 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "bloco de código PL/Perl anônimo" diff --git a/src/pl/plperl/po/ro.po b/src/pl/plperl/po/ro.po new file mode 100644 index 0000000..98431a8 --- /dev/null +++ b/src/pl/plperl/po/ro.po @@ -0,0 +1,185 @@ +# LANGUAGE message translation file for plperl +# Copyright (C) 2010 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# FIRST AUTHOR <EMAIL@ADDRESS>, 2010. +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 9.1\n" +"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" +"POT-Creation-Date: 2011-11-09 20:39+0000\n" +"PO-Revision-Date: 2013-09-05 23:03-0400\n" +"Last-Translator: Gheorge Rosca Codreanu <max@oceanline.co.uk>\n" +"Language-Team: ROMANA <xsoftware.consultancy@gmail.com>\n" +"Language: ro\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Poedit-Language: Romanian\n" +"X-Poedit-Country: ROMANIA\n" +"Plural-Forms: nplurals=2; plural=n != 1;\n" + +#: plperl.c:364 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Dacă true, trusted și untrusted codul Perl se va compila în modul strict." + +#: plperl.c:378 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "codul de inițializare Perl de executat odată când interpreterul Perl este inițializat." + +#: plperl.c:400 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "codul de inițializare Perl de executat odată când plperl este folosit pentru prima oară." + +#: plperl.c:408 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "codul de inițializare Perl de executat odată când plperlu este folosit pentru prima oară." + +#: plperl.c:625 +#: plperl.c:787 +#: plperl.c:792 +#: plperl.c:896 +#: plperl.c:907 +#: plperl.c:948 +#: plperl.c:969 +#: plperl.c:1942 +#: plperl.c:2037 +#: plperl.c:2099 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:626 +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "în timpul execuției PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:788 +msgid "while parsing Perl initialization" +msgstr "în timpul parsing inițializării Perl" + +#: plperl.c:793 +msgid "while running Perl initialization" +msgstr "în timpul rulării intializării Perl" + +#: plperl.c:897 +msgid "while executing PLC_TRUSTED" +msgstr "în timpul execuției PLC_TRUSTED" + +#: plperl.c:908 +msgid "while executing utf8fix" +msgstr "în timpul execuției utf8fix" + +#: plperl.c:949 +msgid "while executing plperl.on_plperl_init" +msgstr "în timpul execuției plperl.on_plperl_init" + +#: plperl.c:970 +msgid "while executing plperl.on_plperlu_init" +msgstr "în timpul execuției plperl.on_plperlu_init" + +#: plperl.c:1014 +#: plperl.c:1614 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl hash conține o coloană \"%s\" inexistentă" + +#: plperl.c:1099 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "numarul dimensiunilor array-ului (%d) depăşeşte maximul admis, %d" + +#: plperl.c:1111 +#: plperl.c:1128 +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "array-urile multidimensionale trebuie să aibă expresii de tip array cu dimensiuni corespunzătoare" + +#: plperl.c:1165 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "nu pot converti un array Perl în tipul de dată %s" + +#: plperl.c:1261 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "nu pot converti tipul de dată hash din Perl într-un tip de dată composit %s" + +#: plperl.c:1272 +msgid "function returning record called in context that cannot accept type record" +msgstr "apel de funcție care are rezultat de tip rând într-un context care nu acceptă tipul rând" + +#: plperl.c:1287 +msgid "PL/Perl function must return reference to hash or array" +msgstr "funcția PL/Perl trebuie să returneze o referință la hash sau array" + +#: plperl.c:1591 +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} nu există" + +#: plperl.c:1595 +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} nu e o referință de tip hash" + +#: plperl.c:1819 +#: plperl.c:2517 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "funcțiile PL/Perl functions nu pot avea ca rezultat tipul %s" + +#: plperl.c:1832 +#: plperl.c:2564 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "funcțiile PL/Perl nu pot accepta tipul %s" + +#: plperl.c:1946 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "compilarea funcției \"%s\" nu a rezultat o referință CODE" + +#: plperl.c:2150 +msgid "set-valued function called in context that cannot accept a set" +msgstr "funcţie set-valoare apelată într-un context care nu acceptă set" + +#: plperl.c:2194 +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "funcția PL/Perl care are rezultat de tip set trebuie să intoarcă o referință la un array sau să folosească return_next" + +#: plperl.c:2314 +msgid "ignoring modified row in DELETE trigger" +msgstr "ignor rândul modificat in triggerul DELETE" + +#: plperl.c:2322 +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "rezultatul unei funcții trigger PL/Perl trebuie să fie de tip undef, \"SKIP\", or \"MODIFY\"" + +#: plperl.c:2448 +#: plperl.c:2454 +msgid "out of memory" +msgstr "memorie insuficientă" + +#: plperl.c:2508 +msgid "trigger functions can only be called as triggers" +msgstr "funcţiile trigger pot fi apelate doar ca triggere" + +#: plperl.c:2884 +msgid "cannot use return_next in a non-SETOF function" +msgstr "nu puteți folosi return_next într-o funcție de tip non-SETOF" + +#: plperl.c:2940 +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "funcția PL/Perl cu rezultat de tip SETOF-composite trebuie să apeleze return_next cu referință la hash" + +#: plperl.c:3655 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "funcție PL/Perl \"%s\"" + +#: plperl.c:3667 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "compilare a funcției PL/Perl \"%s\"" + +#: plperl.c:3676 +msgid "PL/Perl anonymous code block" +msgstr "bloc de cod PL/Perl anonim" + diff --git a/src/pl/plperl/po/ru.po b/src/pl/plperl/po/ru.po new file mode 100644 index 0000000..fa609f7 --- /dev/null +++ b/src/pl/plperl/po/ru.po @@ -0,0 +1,256 @@ +# Russian message translation file for plperl +# Copyright (C) 2012-2016 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# Alexander Lakhin <exclusion@gmail.com>, 2012-2017, 2019. +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL current)\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2020-09-03 11:22+0300\n" +"PO-Revision-Date: 2019-08-29 15:42+0300\n" +"Last-Translator: Alexander Lakhin <exclusion@gmail.com>\n" +"Language-Team: Russian <pgsql-ru-general@postgresql.org>\n" +"Language: ru\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n" +"%10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" + +#: plperl.c:405 +msgid "" +"If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "" +"Если этот параметр равен true, доверенный и недоверенный код Perl будет " +"компилироваться в строгом режиме." + +#: plperl.c:419 +msgid "" +"Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "" +"Код инициализации Perl, который выполняется при инициализации интерпретатора " +"Perl." + +#: plperl.c:441 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "" +"Код инициализации Perl, который выполняется один раз, при первом " +"использовании plperl." + +#: plperl.c:449 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "" +"Код инициализации Perl, который выполняется один раз, при первом " +"использовании plperlu." + +#: plperl.c:646 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "на этой платформе нельзя запустить множество интерпретаторов Perl" + +#: plperl.c:669 plperl.c:853 plperl.c:859 plperl.c:976 plperl.c:988 +#: plperl.c:1031 plperl.c:1054 plperl.c:2136 plperl.c:2244 plperl.c:2312 +#: plperl.c:2375 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:670 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "при выполнении PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:854 +#, c-format +msgid "while parsing Perl initialization" +msgstr "при разборе параметров инициализации Perl" + +#: plperl.c:860 +#, c-format +msgid "while running Perl initialization" +msgstr "при выполнении инициализации Perl" + +#: plperl.c:977 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "при выполнении PLC_TRUSTED" + +#: plperl.c:989 +#, c-format +msgid "while executing utf8fix" +msgstr "при выполнении utf8fix" + +#: plperl.c:1032 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "при выполнении plperl.on_plperl_init" + +#: plperl.c:1055 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "при выполнении plperl.on_plperlu_init" + +#: plperl.c:1101 plperl.c:1789 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl-хеш содержит несуществующий столбец \"%s\"" + +#: plperl.c:1106 plperl.c:1794 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "присвоить значение системному атрибуту \"%s\" нельзя" + +#: plperl.c:1194 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "число размерностей массива (%d) превышает предел (%d)" + +#: plperl.c:1206 plperl.c:1223 +#, c-format +msgid "" +"multidimensional arrays must have array expressions with matching dimensions" +msgstr "" +"для многомерных массивов должны задаваться выражения с соответствующими " +"размерностями" + +#: plperl.c:1259 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "Perl-массив нельзя преобразовать в тип не массива %s" + +#: plperl.c:1362 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "Perl-хеш нельзя преобразовать в не составной тип %s" + +#: plperl.c:1384 plperl.c:3284 +#, c-format +msgid "" +"function returning record called in context that cannot accept type record" +msgstr "" +"функция, возвращающая запись, вызвана в контексте, не допускающем этот тип" + +#: plperl.c:1443 +#, c-format +msgid "lookup failed for type %s" +msgstr "найти тип %s не удалось" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} не существует" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} - не ссылка на хеш" + +#: plperl.c:1799 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "присвоить значение генерируемому столбцу \"%s\" нельзя" + +#: plperl.c:2011 plperl.c:2849 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "функции PL/Perl не могут возвращать тип %s" + +#: plperl.c:2024 plperl.c:2890 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "функции PL/Perl не могут принимать тип %s" + +#: plperl.c:2141 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "не удалось получить ссылку на код после компиляции функции \"%s\"" + +#: plperl.c:2232 +#, c-format +msgid "didn't get a return item from function" +msgstr "не удалось получить возвращаемый элемент от функции" + +#: plperl.c:2276 plperl.c:2343 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "не удалось получить $_TD" + +#: plperl.c:2300 plperl.c:2363 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "не удалось получить возвращаемый элемент от триггерной функции" + +#: plperl.c:2422 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "" +"функция, возвращающая множество, вызвана в контексте, где ему нет места" + +#: plperl.c:2467 +#, c-format +msgid "" +"set-returning PL/Perl function must return reference to array or use " +"return_next" +msgstr "" +"функция PL/Perl, возвращающая множество, должна возвращать ссылку на массив " +"или вызывать return_next" + +#: plperl.c:2588 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "в триггере DELETE изменённая строка игнорируется" + +#: plperl.c:2596 +#, c-format +msgid "" +"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "" +"результатом триггерной функции PL/Perl должен быть undef, \"SKIP\" или " +"\"MODIFY\"" + +#: plperl.c:2844 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "триггерные функции могут вызываться только в триггерах" + +#: plperl.c:3191 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "" +"результат запроса содержит слишком много строк для передачи в массиве Perl" + +#: plperl.c:3261 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "" +"return_next можно использовать только в функциях, возвращающих множества" + +#: plperl.c:3335 +#, c-format +msgid "" +"SETOF-composite-returning PL/Perl function must call return_next with " +"reference to hash" +msgstr "" +"функция PL/Perl, возвращающая составное множество, должна вызывать " +"return_next со ссылкой на хеш" + +#: plperl.c:4110 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "функция PL/Perl \"%s\"" + +#: plperl.c:4122 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "компиляция функции PL/Perl \"%s\"" + +#: plperl.c:4131 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "анонимный блок кода PL/Perl" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "функция PL/Perl должна возвращать ссылку на хеш или массив" + +#~ msgid "out of memory" +#~ msgstr "нехватка памяти" diff --git a/src/pl/plperl/po/sv.po b/src/pl/plperl/po/sv.po new file mode 100644 index 0000000..a856fc0 --- /dev/null +++ b/src/pl/plperl/po/sv.po @@ -0,0 +1,222 @@ +# Swedish message translation file for plperl +# Copyright (C) 2014 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# Mats Erik Andersson <bsd@gisladisker.se>, 2014. +# Dennis Björklund <db@zigo.dhs.org> 2017, 2018, 2019, 2020. +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 13\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2020-04-11 01:08+0000\n" +"PO-Revision-Date: 2020-04-11 08:42+0200\n" +"Last-Translator: Dennis Björklund <db@zigo.dhs.org>\n" +"Language-Team: Swedish <pgsql-translators@postgresql.org>\n" +"Language: sv\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=n != 1;\n" + +#: plperl.c:405 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Om sant, tillförlitlig och otillförlitlig Perl-kod kommer kompileras i strikt läge." + +#: plperl.c:419 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Perl-kod för initialisering, utföres när perl-tolken förbereds." + +#: plperl.c:441 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Perl-kod för engångs-initialisering då plperl används första gången." + +#: plperl.c:449 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Perl-kod för engångs-initialisering då plperlu används första gången." + +#: plperl.c:646 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "kan inte utnyttja flera Perl-interpretorer på denna plattform" + +#: plperl.c:669 plperl.c:853 plperl.c:859 plperl.c:976 plperl.c:988 +#: plperl.c:1031 plperl.c:1054 plperl.c:2136 plperl.c:2244 plperl.c:2312 +#: plperl.c:2375 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:670 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "vid utförande av PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:854 +#, c-format +msgid "while parsing Perl initialization" +msgstr "vid tolkning av perls initieringssteg" + +#: plperl.c:860 +#, c-format +msgid "while running Perl initialization" +msgstr "vid utförande av perls initieringssteg" + +#: plperl.c:977 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "vid utförande av PLC_TRUSTED" + +#: plperl.c:989 +#, c-format +msgid "while executing utf8fix" +msgstr "vid utförande av utf8fix" + +#: plperl.c:1032 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "vid utförande av plperl.on_plperl_init" + +#: plperl.c:1055 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "vid utförande av plperl.on_plperlu_init" + +#: plperl.c:1101 plperl.c:1789 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perlhash innehåller en okänd kolumn \"%s\"." + +#: plperl.c:1106 plperl.c:1794 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "kan inte sätta systemattribut \"%s\"" + +#: plperl.c:1194 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "antalet array-dimensioner (%d) överskrider det maximalt tillåtna (%d)" + +#: plperl.c:1206 plperl.c:1223 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "flerdimensionella vektorer måste ha array-uttryck av passande dimensioner" + +#: plperl.c:1259 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "kan inte omvandla perlvektor till icke-array av typ \"%s\"." + +#: plperl.c:1362 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "kan inte omvandla en perlhash till icke-composite-typ \"%s\"." + +#: plperl.c:1384 plperl.c:3284 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "en funktion med post som värde anropades i sammanhang där poster inte kan godtagas." + +#: plperl.c:1443 +#, c-format +msgid "lookup failed for type %s" +msgstr "uppslag misslyckades för typen \"%s\"" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} finns inte." + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} är inte en hash-referens." + +#: plperl.c:1799 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "kan inte sätta genererad kolumn \"%s\"" + +#: plperl.c:2011 plperl.c:2849 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "Funktioner i PL/Perl kan inte svara med typ \"%s\"." + +#: plperl.c:2024 plperl.c:2890 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "Funktioner i PL/Perl kan inte hantera typ \"%s\"." + +#: plperl.c:2141 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "fick inte en CODE-referens vid kompilering av funktionen \"%s\"." + +#: plperl.c:2232 +#, c-format +msgid "didn't get a return item from function" +msgstr "fick inget returnvärde från funktion" + +#: plperl.c:2276 plperl.c:2343 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "kunde inte hämta $_TD" + +#: plperl.c:2300 plperl.c:2363 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "fick inget returvärde från utlösarfunktion" + +#: plperl.c:2422 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "en funktion som returnerar en mängd anropades i kontext som inte godtar en mängd" + +#: plperl.c:2467 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "En mängd-returnerande funktion i PL/Perl måste göra det som referens eller med return_next." + +#: plperl.c:2588 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "Lämnar ändrad rad orörd i en DELETE-triggning" + +#: plperl.c:2596 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "resultat av en triggningsfunktion i PL/Perl måste vara undef, \"SKIP\" eller \"MODIFY\"." + +#: plperl.c:2844 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "Triggningsfunktioner kan bara anropas vid triggning." + +#: plperl.c:3191 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "frågeresultatet har för många rader för att få plats i en Perl-array" + +#: plperl.c:3261 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "får inte nyttja return_next i funktion som ej är SETOF" + +#: plperl.c:3335 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "En funktion i PL/Perl med värderetur som SETOF måste anropa return_next med en hashreferens" + +#: plperl.c:4110 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl-funktion \"%s\"." + +#: plperl.c:4122 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "kompilering av PL/Perl-funktion \"%s\"" + +#: plperl.c:4131 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "Anonymt kodblock i PL/Perl." diff --git a/src/pl/plperl/po/tr.po b/src/pl/plperl/po/tr.po new file mode 100644 index 0000000..a8708e4 --- /dev/null +++ b/src/pl/plperl/po/tr.po @@ -0,0 +1,236 @@ +# LANGUAGE message translation file for plperl +# Copyright (C) 2009 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# FIRST AUTHOR <EMAIL@ADDRESS>, 2009. +# +msgid "" +msgstr "" +"Project-Id-Version: PostgreSQL 8.4\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-04-26 13:38+0000\n" +"PO-Revision-Date: 2019-06-13 17:04+0300\n" +"Last-Translator: Devrim GÜNDÜZ <devrim@gunduz.org>\n" +"Language-Team: Turkish <devrim@gunduz.org>\n" +"Language: tr\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: Poedit 1.8.7.1\n" + +#: plperl.c:409 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Doğru ise, trusted ve untrusted Perl kodları strict modda derlenecektir" + +#: plperl.c:423 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Perl yorumlayıcısı ilklendirildiğinde çalışacak Perl ilklendirme kodu." + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "plperl ilk kez kullanıldığında çalışacak Perl ilklendirme kodu" + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "plperlu ilk kez kullanıldığında çalışacak Perl ilklendirme kodu" + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "bu platformda birden fazla Perl interpreter ayrılamıyor" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2157 plperl.c:2267 plperl.c:2335 +#: plperl.c:2398 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "PostgreSQL::InServer::SPI::bootstrap çalıştırılırken" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "Perl ilklendirmesi ayrıştırılırken" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "Perl ilklendirmesi sırasında" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr " PLC_TRUSTED çalıştırılırken" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "utf8fix çalıştırılırken" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "plperl.on_plperl_init çalıştırılırken" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "plperl.on_plperlu_init çalıştırılırken" + +#: plperl.c:1105 plperl.c:1796 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl hashi olmayan kolonu içeriyor: \"%s\"" + +#: plperl.c:1110 plperl.c:1801 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "\"%s\" sistem niteliği ayarlanamıyor" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "dizin boyut sayısı (%d), izin verilern en yüksek değerini (%d) aşmaktadır" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "çok boyutlu dizinler boyut sayısı kadar dizin ifade sayısına sahip olmalıdırlar" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "Perl dizisi (array) dizi olmayan %s tipine dönüştürülemiyor" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "Perl hash'i kompozit olmayan %s tipine dönüştürülemez" + +#: plperl.c:1388 plperl.c:3309 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "tip kaydı içermeyen alanda çağırılan ve kayıt döndüren fonksiyon" + +#: plperl.c:1447 +#, c-format +msgid "lookup failed for type %s" +msgstr "%s tipi için arama (lookup) başarısız oldu" + +#: plperl.c:1771 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} mevcut değil" + +#: plperl.c:1775 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} hash referansı değil" + +#: plperl.c:1806 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "oluşturulan \"%s\" sütunu ayarlanamıyor" + +#: plperl.c:2032 plperl.c:2874 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl fonksiyonları %s veri tipini döndüremezler" + +#: plperl.c:2045 plperl.c:2915 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl fonksiyonları %s tipini kabul etmez" + +#: plperl.c:2162 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "\"%s\" fonksiyonu derlenirken CODE referansı alınamadı" + +#: plperl.c:2255 +#, c-format +msgid "didn't get a return item from function" +msgstr "fonksiyonden dönüş (return) değeri alınamadı" + +#: plperl.c:2299 plperl.c:2366 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "$_TD getirilemedi" + +#: plperl.c:2323 plperl.c:2386 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "trigger fonksiyonundan dönüş (return) değeri alınamadı" + +#: plperl.c:2447 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "set değerini kabul etmediği ortamda set değeri alan fonksiyon çağırılmış" + +#: plperl.c:2492 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "se dönen PL/Perl fonksiyonu return_next kullanmalı ya da bir diziye referans dönmelidir" + +#: plperl.c:2613 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "DELETE triggerındaki değiştirilmiş satır gözardı ediliyor" + +#: plperl.c:2621 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "PL/Perl trigger fonksiyonun sonucu undef, \"SKIP\" ya da \"MODIFY\" olmalıdır" + +#: plperl.c:2869 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "trigger fonksiyonları sadece trigger olarak çağırılabilirler" + +#: plperl.c:3216 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "sorgu sonucunda bir Perl dizisine (array) sığabilecekten çok fazla satır var" + +#: plperl.c:3286 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "SETOF olmayan bir fonksiyonda return_next kullanılamaz" + +#: plperl.c:3360 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "SETOF-composite döndüren PL/Perl fonksiyonları return_next'i hash'e referans olarak çağırmalıdır" + +#: plperl.c:4135 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "\"%s\" PL/Perl fonksiyonu" + +#: plperl.c:4147 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "\"%s\" PL/Perl fonksiyonunun derlenmesi" + +#: plperl.c:4156 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "PL/Perl anonim kod bloğu" + +#~ msgid "composite-returning PL/Perl function must return reference to hash" +#~ msgstr "composite döndüren PL/Perl fonksiyonu hash'e referans dönmelidir" + +#~ msgid "out of memory" +#~ msgstr "yetersiz bellek" + +#~ msgid "creation of Perl function \"%s\" failed: %s" +#~ msgstr " \"%s\" Perl fonksiyonunun yaratılması başarısız oldu: %s" + +#~ msgid "error from Perl function \"%s\": %s" +#~ msgstr "Perl fonksiyonunda hata: \"%s\": %s" + +#~ msgid "PL/Perl function must return reference to hash or array" +#~ msgstr "PL/Perl fonksiyonu hash ya da dizine referans dönmelidir" diff --git a/src/pl/plperl/po/uk.po b/src/pl/plperl/po/uk.po new file mode 100644 index 0000000..28a5884 --- /dev/null +++ b/src/pl/plperl/po/uk.po @@ -0,0 +1,222 @@ +msgid "" +msgstr "" +"Project-Id-Version: postgresql\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2020-09-21 21:08+0000\n" +"PO-Revision-Date: 2020-09-22 13:43\n" +"Last-Translator: \n" +"Language-Team: Ukrainian\n" +"Language: uk_UA\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=4; plural=((n%10==1 && n%100!=11) ? 0 : ((n%10 >= 2 && n%10 <=4 && (n%100 < 12 || n%100 > 14)) ? 1 : ((n%10 == 0 || (n%10 >= 5 && n%10 <=9)) || (n%100 >= 11 && n%100 <= 14)) ? 2 : 3));\n" +"X-Crowdin-Project: postgresql\n" +"X-Crowdin-Project-ID: 324573\n" +"X-Crowdin-Language: uk\n" +"X-Crowdin-File: /DEV_13/plperl.pot\n" +"X-Crowdin-File-ID: 516\n" + +#: plperl.c:405 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "Якщо увімкнено, надійний і ненадійний код Perl буде скомпільований в суворому режимі." + +#: plperl.c:419 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Виконати ініціалізаційний код під час ініціалізації інтерпретатора Perl." + +#: plperl.c:441 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Виконати код ініціалізації один раз під час першого використання plperl." + +#: plperl.c:449 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Виконати код ініціалізації один раз під час першого використання plperlu." + +#: plperl.c:646 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "не можна розмістити декілька Perl інтерпретаторів на цій платформі" + +#: plperl.c:669 plperl.c:853 plperl.c:859 plperl.c:976 plperl.c:988 +#: plperl.c:1031 plperl.c:1054 plperl.c:2136 plperl.c:2244 plperl.c:2312 +#: plperl.c:2375 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:670 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "під час виконання PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:854 +#, c-format +msgid "while parsing Perl initialization" +msgstr "під час обробки ініціалізації Perl" + +#: plperl.c:860 +#, c-format +msgid "while running Perl initialization" +msgstr "під час запуску Perl ініціалізації" + +#: plperl.c:977 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "під час виконання PLC_TRUSTED" + +#: plperl.c:989 +#, c-format +msgid "while executing utf8fix" +msgstr "під час виконання utf8fix" + +#: plperl.c:1032 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "під час виконання plperl.on_plperl_init" + +#: plperl.c:1055 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "під час виконання plperl.on_plperlu_init" + +#: plperl.c:1101 plperl.c:1789 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "хеш Perl містить неіснуючу колонку \"%s\"" + +#: plperl.c:1106 plperl.c:1794 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "не вдалося встановити системний атрибут \"%s\"" + +#: plperl.c:1194 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "число вимірів масива (%d) перевищує ліміт (%d)" + +#: plperl.c:1206 plperl.c:1223 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "для багатовимірних масивів повинні задаватись вирази з відповідними вимірами" + +#: plperl.c:1259 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "неможливо конвертувати масив Perl у тип не масиву %s" + +#: plperl.c:1362 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "неможливо конвертувати хеш Perl у нескладений тип %s" + +#: plperl.c:1384 plperl.c:3284 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "функція, що повертає набір, викликана у контексті, що не приймає тип запис" + +#: plperl.c:1443 +#, c-format +msgid "lookup failed for type %s" +msgstr "неможливо фільтрувати для типу %s" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} не існує" + +#: plperl.c:1768 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} не є посиланням на хеш" + +#: plperl.c:1799 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "неможливо оновити згенерований стовпець \"%s\"" + +#: plperl.c:2011 plperl.c:2849 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "функції PL/Perl не можуть повертати тип %s" + +#: plperl.c:2024 plperl.c:2890 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "функції PL/Perl не можуть приймати тип %s" + +#: plperl.c:2141 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "не отримано посилання CODE з функції компіляції \"%s\"" + +#: plperl.c:2232 +#, c-format +msgid "didn't get a return item from function" +msgstr "не отримано елемент результату з функції" + +#: plperl.c:2276 plperl.c:2343 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "не вдалось отримати $_TD" + +#: plperl.c:2300 plperl.c:2363 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "не отримано елемент результату з функції-тригеру" + +#: plperl.c:2422 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "функція \"set-valued\" викликана в контексті, де йому немає місця" + +#: plperl.c:2467 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "функція PL/Perl, що вертає набір значень, повинна посилатися на масив або використовувати return_next" + +#: plperl.c:2588 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "ігнорується змінений рядок у тригері DELETE" + +#: plperl.c:2596 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "результат тригерної функції PL/Perl повинен бути undef, \"SKIP\" або \"MODIFY\"" + +#: plperl.c:2844 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "тригер-функція може викликатися лише як тригер" + +#: plperl.c:3191 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "результат запиту має забагато рядків для відповідності в масиві Perl" + +#: plperl.c:3261 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "не можна використовувати return_next в функціях, що не повертають набори даних" + +#: plperl.c:3335 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "Функція PL/Perl, що повертає набір композитних даних, повинна викликати return_next з посиланням на хеш" + +#: plperl.c:4110 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl функція \"%s\"" + +#: plperl.c:4122 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "компіляція функції PL/Perl \"%s\"" + +#: plperl.c:4131 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "анонімний блок коду PL/Perl" + diff --git a/src/pl/plperl/po/vi.po b/src/pl/plperl/po/vi.po new file mode 100644 index 0000000..15ba874 --- /dev/null +++ b/src/pl/plperl/po/vi.po @@ -0,0 +1,242 @@ +# LANGUAGE message translation file for plperl +# Copyright (C) 2018 PostgreSQL Global Development Group +# This file is distributed under the same license as the plperl (PostgreSQL) package. +# FIRST AUTHOR <kakalot49@gmail.com>, 2018. +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL) 11\n" +"Report-Msgid-Bugs-To: pgsql-bugs@postgresql.org\n" +"POT-Creation-Date: 2018-04-22 12:08+0000\n" +"PO-Revision-Date: 2018-04-29 23:57+0900\n" +"Language-Team: <pgvn_translators@postgresql.vn>\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"X-Generator: Poedit 2.0.6\n" +"Last-Translator: Dang Minh Huong <kakalot49@gmail.com>\n" +"Plural-Forms: nplurals=1; plural=0;\n" +"Language: vi_VN\n" + +#: plperl.c:409 +msgid "" +"If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "" +"Nếu đúng, mã perl đáng tin cậy(PL/Perl ) và không đáng tin cậy(PL/PerlU) sẽ " +"được biên dịch trong chế độ strict." + +#: plperl.c:423 +msgid "" +"Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "Mã Perl được thực thi khi trình thông dịch Perl được khởi tạo." + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "Mã Perl được thực thi khi plperl được sử dụng lần đầu tiên." + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "Mã Perl được thực thi khi plperlu được sử dụng lần đầu tiên." + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "không thể cấp phát nhiều trình thông dịch Perl trên hệ điều hành này" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2141 plperl.c:2251 plperl.c:2319 +#: plperl.c:2382 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "trong khi thực thi PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "trong khi phân tích cú pháp khởi tạo Perl" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "trong khi chạy cú pháp khởi tạo Perl" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "trong khi chạy PLC_TRUSTED" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "trong khi thực thi utf8fix" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "trong khi thực thi plperl.on_plperl_init" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "trong khi thực thi plperl.plperlu_init" + +#: plperl.c:1105 plperl.c:1785 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Giá trị băm Perl chứa cột không tồn tại \"%s\"" + +#: plperl.c:1110 plperl.c:1790 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "không thể thiết lập attribute hệ thống \"%s\"" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "số lượng chiều của mảng (%d) vượt quá số lượng tối đa cho phép (%d)" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "" +"multidimensional arrays must have array expressions with matching dimensions" +msgstr "mảng đa chiều phải có biểu thức mảng tương ứng với các chiều" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "không thể chuyển đổi mảng Perl thành kiểu không phải mảng %s" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "" +"không thể chuyển đổi giá trị băm Perl thành kiểu không phải-composite %s" + +#: plperl.c:1388 plperl.c:3286 +#, c-format +msgid "" +"function returning record called in context that cannot accept type record" +msgstr "" +"hàm trả về bản ghi được gọi trong ngữ cảnh không thể chấp nhận kiểu bản ghi" + +#: plperl.c:1408 +#, c-format +msgid "PL/Perl function must return reference to hash or array" +msgstr "Hàm PL/Perl phải trả về tham thiếu tới giá trị băm hoặc mảng" + +#: plperl.c:1445 +#, c-format +msgid "lookup failed for type %s" +msgstr "không tìm thấy kiểu dữ liệu %s" + +#: plperl.c:1760 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new} không tồn tại" + +#: plperl.c:1764 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new} không phải là một tham chiếu giá trị băm" + +#: plperl.c:2016 plperl.c:2858 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "Hàm PL/Perl không thể trả về kiểu %s" + +#: plperl.c:2029 plperl.c:2899 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "Hàm PL/Perl không thể chấp nhận kiểu %s" + +#: plperl.c:2146 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "không nhận được tham chiếu CODE từ hàm biên dịch \"%s\"" + +#: plperl.c:2239 +#, c-format +msgid "didn't get a return item from function" +msgstr "không nhận được một mục trả về từ hàm" + +#: plperl.c:2283 plperl.c:2350 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "không thể fetch $_TD" + +#: plperl.c:2307 plperl.c:2370 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "không nhận được một mục trả về từ hàm trigger" + +#: plperl.c:2431 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "" +"hàm thiết lập giá trị được gọi trong ngữ cảnh không thể chấp nhận một tập " +"hợp" + +#: plperl.c:2476 +#, c-format +msgid "" +"set-returning PL/Perl function must return reference to array or use " +"return_next" +msgstr "" +"hàm thiết lập-trả về PL/Perl phải trả về tham chiếu tới mảng hay sử dụng " +"return_next" + +#: plperl.c:2597 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "bỏ qua hàng đã sửa đổi trong trigger DELETE" + +#: plperl.c:2605 +#, c-format +msgid "" +"result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "" +"kết quả của hàm trigger PL/Perl phải là undef, \"SKIP\" hoặc \"MODIFY\"" + +#: plperl.c:2853 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "các hàm trigger chỉ có thể được gọi như những trigger" + +#: plperl.c:3193 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "kết quả truy vấn có quá nhiều hàng có thể vừa với một mảng Perl" + +#: plperl.c:3263 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "không thể sử dụng return_next trong hàm không phải-SETOF" + +#: plperl.c:3337 +#, c-format +msgid "" +"SETOF-composite-returning PL/Perl function must call return_next with " +"reference to hash" +msgstr "" +"Hàm PL/Perl trả về SETOF-composite phải gọi return_next với tham chiếu tới " +"giá trị băm" + +#: plperl.c:4115 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "Hàm PL/Perl \"%s\"" + +#: plperl.c:4127 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "biên dịch hàm PL/Perl \"%s\"" + +#: plperl.c:4136 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "Khối mã ẩn danh PL/Perl" diff --git a/src/pl/plperl/po/zh_CN.po b/src/pl/plperl/po/zh_CN.po new file mode 100644 index 0000000..01957bf --- /dev/null +++ b/src/pl/plperl/po/zh_CN.po @@ -0,0 +1,221 @@ +# LANGUAGE message translation file for plperl +# Copyright (C) 2010 PostgreSQL Global Development Group +# This file is distributed under the same license as the PostgreSQL package. +# FIRST AUTHOR <EMAIL@ADDRESS>, 2010. +# +msgid "" +msgstr "" +"Project-Id-Version: plperl (PostgreSQL) 12\n" +"Report-Msgid-Bugs-To: pgsql-bugs@lists.postgresql.org\n" +"POT-Creation-Date: 2019-05-22 17:56+0800\n" +"PO-Revision-Date: 2019-06-03 17:30+0800\n" +"Last-Translator: Jie Zhang <zhangjie2@cn.fujitsu.com>\n" +"Language-Team: Chinese (Simplified) <zhangjie2@cn.fujitsu.com>\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Language: zh_CN\n" +"X-Generator: Poedit 1.5.7\n" + +#: plperl.c:409 +msgid "If true, trusted and untrusted Perl code will be compiled in strict mode." +msgstr "如果为真的话，那么信任和非信任的Perl代码将以限制模式编译." + +#: plperl.c:423 +msgid "Perl initialization code to execute when a Perl interpreter is initialized." +msgstr "当初始化一个Perl解释器时候执行Perl初始化代码" + +#: plperl.c:445 +msgid "Perl initialization code to execute once when plperl is first used." +msgstr "在第一次使用plperl的时候执行一次Perl初始化代码" + +#: plperl.c:453 +msgid "Perl initialization code to execute once when plperlu is first used." +msgstr "在plperlu第一次使用的时候执行一次Perl初始化代码" + +#: plperl.c:650 +#, c-format +msgid "cannot allocate multiple Perl interpreters on this platform" +msgstr "在这个平台上无法分配多个Perl解释器" + +#: plperl.c:673 plperl.c:857 plperl.c:863 plperl.c:980 plperl.c:992 +#: plperl.c:1035 plperl.c:1058 plperl.c:2157 plperl.c:2267 plperl.c:2335 +#: plperl.c:2398 +#, c-format +msgid "%s" +msgstr "%s" + +#: plperl.c:674 +#, c-format +msgid "while executing PostgreSQL::InServer::SPI::bootstrap" +msgstr "同时在执行PostgreSQL::InServer::SPI::bootstrap" + +#: plperl.c:858 +#, c-format +msgid "while parsing Perl initialization" +msgstr "同时在解析Perl初始化" + +#: plperl.c:864 +#, c-format +msgid "while running Perl initialization" +msgstr "同时在运行Perl初始化" + +#: plperl.c:981 +#, c-format +msgid "while executing PLC_TRUSTED" +msgstr "同时在执行PLC_TRUSTED" + +#: plperl.c:993 +#, c-format +msgid "while executing utf8fix" +msgstr "同时在执行utf8fix" + +#: plperl.c:1036 +#, c-format +msgid "while executing plperl.on_plperl_init" +msgstr "同时在执行plperl.on_plperl_init" + +#: plperl.c:1059 +#, c-format +msgid "while executing plperl.on_plperlu_init" +msgstr "同时在执行plperl.on_plperlu_init" + +#: plperl.c:1105 plperl.c:1796 +#, c-format +msgid "Perl hash contains nonexistent column \"%s\"" +msgstr "Perl的哈希功能包含不存在的列\"%s\"" + +#: plperl.c:1110 plperl.c:1801 +#, c-format +msgid "cannot set system attribute \"%s\"" +msgstr "不能设置系统属性\"%s\"" + +#: plperl.c:1198 +#, c-format +msgid "number of array dimensions (%d) exceeds the maximum allowed (%d)" +msgstr "数组的维数(%d)超过最大允许值(%d)" + +#: plperl.c:1210 plperl.c:1227 +#, c-format +msgid "multidimensional arrays must have array expressions with matching dimensions" +msgstr "多维数组必须有符合维度的数组表达式" + +#: plperl.c:1263 +#, c-format +msgid "cannot convert Perl array to non-array type %s" +msgstr "无法将Perl数组转换成非数组类型 %s" + +#: plperl.c:1366 +#, c-format +msgid "cannot convert Perl hash to non-composite type %s" +msgstr "无法将Perl哈希类型转换成非组合类型 %s" + +#: plperl.c:1388 plperl.c:3309 +#, c-format +msgid "function returning record called in context that cannot accept type record" +msgstr "返回值类型是记录的函数在不接受使用记录类型的环境中调用" + +#: plperl.c:1447 +#, c-format +msgid "lookup failed for type %s" +msgstr "类型%s查找失败" + +#: plperl.c:1771 +#, c-format +msgid "$_TD->{new} does not exist" +msgstr "$_TD->{new}不存在" + +#: plperl.c:1775 +#, c-format +msgid "$_TD->{new} is not a hash reference" +msgstr "$_TD->{new}不是一个哈希引用" + +#: plperl.c:1806 +#, c-format +msgid "cannot set generated column \"%s\"" +msgstr "无法设置生成的列\"%s\"" + +#: plperl.c:2032 plperl.c:2874 +#, c-format +msgid "PL/Perl functions cannot return type %s" +msgstr "PL/Perl函数无法返回类型%s" + +#: plperl.c:2045 plperl.c:2915 +#, c-format +msgid "PL/Perl functions cannot accept type %s" +msgstr "PL/Perl 函数无法使用类型%s" + +#: plperl.c:2162 +#, c-format +msgid "didn't get a CODE reference from compiling function \"%s\"" +msgstr "没有从正在编译的函数 \"%s\"得到CODE参考" + +#: plperl.c:2255 +#, c-format +msgid "didn't get a return item from function" +msgstr "没有从函数得到一个返回项" + +#: plperl.c:2299 plperl.c:2366 +#, c-format +msgid "couldn't fetch $_TD" +msgstr "无法取得 $_TD" + +#: plperl.c:2323 plperl.c:2386 +#, c-format +msgid "didn't get a return item from trigger function" +msgstr "没有从触发器函数得到一个返回项" + +#: plperl.c:2447 +#, c-format +msgid "set-valued function called in context that cannot accept a set" +msgstr "集值函数在不能使用集合的环境中调用" + +#: plperl.c:2492 +#, c-format +msgid "set-returning PL/Perl function must return reference to array or use return_next" +msgstr "返回集合的PL/Perl函数必须返回对数组的引用或者使用return_next" + +#: plperl.c:2613 +#, c-format +msgid "ignoring modified row in DELETE trigger" +msgstr "在DELETE触发器中忽略已修改的记录" + +#: plperl.c:2621 +#, c-format +msgid "result of PL/Perl trigger function must be undef, \"SKIP\", or \"MODIFY\"" +msgstr "PL/Perl 触发器函数的结果必须是undef, \"SKIP\", 或 \"MODIFY\"" + +#: plperl.c:2869 +#, c-format +msgid "trigger functions can only be called as triggers" +msgstr "触发器函数只能以触发器的形式调用" + +#: plperl.c:3216 +#, c-format +msgid "query result has too many rows to fit in a Perl array" +msgstr "查询结果中的行太多，无法放在一个Perl数组中" + +#: plperl.c:3286 +#, c-format +msgid "cannot use return_next in a non-SETOF function" +msgstr "不能在非SETOF函数中使用return_next" + +#: plperl.c:3360 +#, c-format +msgid "SETOF-composite-returning PL/Perl function must call return_next with reference to hash" +msgstr "返回SETOF-组合类型值的PL/Perl函数必须调用带有对哈希引用的return_next" + +#: plperl.c:4135 +#, c-format +msgid "PL/Perl function \"%s\"" +msgstr "PL/Perl函数\"%s\"" + +#: plperl.c:4147 +#, c-format +msgid "compilation of PL/Perl function \"%s\"" +msgstr "编译PL/Perl函数\"%s\"" + +#: plperl.c:4156 +#, c-format +msgid "PL/Perl anonymous code block" +msgstr "PL/Perl匿名代码块" diff --git a/src/pl/plperl/ppport.h b/src/pl/plperl/ppport.h new file mode 100644 index 0000000..8c23656 --- /dev/null +++ b/src/pl/plperl/ppport.h @@ -0,0 +1,7063 @@ +#if 0 +<<'SKIP'; +#endif +/* +---------------------------------------------------------------------- + + ppport.h -- Perl/Pollution/Portability Version 3.19 + + Automatically created by Devel::PPPort running under perl 5.011002. + + Do NOT edit this file directly! -- Edit PPPort_pm.PL and the + includes in parts/inc/ instead. + + Use 'perldoc ppport.h' to view the documentation below. + +---------------------------------------------------------------------- + +SKIP + +=pod + +=head1 NAME + +ppport.h - Perl/Pollution/Portability version 3.19 + +=head1 SYNOPSIS + + perl ppport.h [options] [source files] + + Searches current directory for files if no [source files] are given + + --help show short help + + --version show version + + --patch=file write one patch file with changes + --copy=suffix write changed copies with suffix + --diff=program use diff program and options + + --compat-version=version provide compatibility with Perl version + --cplusplus accept C++ comments + + --quiet don't output anything except fatal errors + --nodiag don't show diagnostics + --nohints don't show hints + --nochanges don't suggest changes + --nofilter don't filter input files + + --strip strip all script and doc functionality from + ppport.h + + --list-provided list provided API + --list-unsupported list unsupported API + --api-info=name show Perl API portability information + +=head1 COMPATIBILITY + +This version of F<ppport.h> is designed to support operation with Perl +installations back to 5.003, and has been tested up to 5.10.0. + +=head1 OPTIONS + +=head2 --help + +Display a brief usage summary. + +=head2 --version + +Display the version of F<ppport.h>. + +=head2 --patch=I<file> + +If this option is given, a single patch file will be created if +any changes are suggested. This requires a working diff program +to be installed on your system. + +=head2 --copy=I<suffix> + +If this option is given, a copy of each file will be saved with +the given suffix that contains the suggested changes. This does +not require any external programs. Note that this does not +automagically add a dot between the original filename and the +suffix. If you want the dot, you have to include it in the option +argument. + +If neither C<--patch> or C<--copy> are given, the default is to +simply print the diffs for each file. This requires either +C<Text::Diff> or a C<diff> program to be installed. + +=head2 --diff=I<program> + +Manually set the diff program and options to use. The default +is to use C<Text::Diff>, when installed, and output unified +context diffs. + +=head2 --compat-version=I<version> + +Tell F<ppport.h> to check for compatibility with the given +Perl version. The default is to check for compatibility with Perl +version 5.003. You can use this option to reduce the output +of F<ppport.h> if you intend to be backward compatible only +down to a certain Perl version. + +=head2 --cplusplus + +Usually, F<ppport.h> will detect C++ style comments and +replace them with C style comments for portability reasons. +Using this option instructs F<ppport.h> to leave C++ +comments untouched. + +=head2 --quiet + +Be quiet. Don't print anything except fatal errors. + +=head2 --nodiag + +Don't output any diagnostic messages. Only portability +alerts will be printed. + +=head2 --nohints + +Don't output any hints. Hints often contain useful portability +notes. Warnings will still be displayed. + +=head2 --nochanges + +Don't suggest any changes. Only give diagnostic output and hints +unless these are also deactivated. + +=head2 --nofilter + +Don't filter the list of input files. By default, files not looking +like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped. + +=head2 --strip + +Strip all script and documentation functionality from F<ppport.h>. +This reduces the size of F<ppport.h> dramatically and may be useful +if you want to include F<ppport.h> in smaller modules without +increasing their distribution size too much. + +The stripped F<ppport.h> will have a C<--unstrip> option that allows +you to undo the stripping, but only if an appropriate C<Devel::PPPort> +module is installed. + +=head2 --list-provided + +Lists the API elements for which compatibility is provided by +F<ppport.h>. Also lists if it must be explicitly requested, +if it has dependencies, and if there are hints or warnings for it. + +=head2 --list-unsupported + +Lists the API elements that are known not to be supported by +F<ppport.h> and below which version of Perl they probably +won't be available or work. + +=head2 --api-info=I<name> + +Show portability information for API elements matching I<name>. +If I<name> is surrounded by slashes, it is interpreted as a regular +expression. + +=head1 DESCRIPTION + +In order for a Perl extension (XS) module to be as portable as possible +across differing versions of Perl itself, certain steps need to be taken. + +=over 4 + +=item * + +Including this header is the first major one. This alone will give you +access to a large part of the Perl API that hasn't been available in +earlier Perl releases. Use + + perl ppport.h --list-provided + +to see which API elements are provided by ppport.h. + +=item * + +You should avoid using deprecated parts of the API. For example, using +global Perl variables without the C<PL_> prefix is deprecated. Also, +some API functions used to have a C<perl_> prefix. Using this form is +also deprecated. You can safely use the supported API, as F<ppport.h> +will provide wrappers for older Perl versions. + +=item * + +If you use one of a few functions or variables that were not present in +earlier versions of Perl, and that can't be provided using a macro, you +have to explicitly request support for these functions by adding one or +more C<#define>s in your source code before the inclusion of F<ppport.h>. + +These functions or variables will be marked C<explicit> in the list shown +by C<--list-provided>. + +Depending on whether you module has a single or multiple files that +use such functions or variables, you want either C<static> or global +variants. + +For a C<static> function or variable (used only in a single source +file), use: + + #define NEED_function + #define NEED_variable + +For a global function or variable (used in multiple source files), +use: + + #define NEED_function_GLOBAL + #define NEED_variable_GLOBAL + +Note that you mustn't have more than one global request for the +same function or variable in your project. + + Function / Variable Static Request Global Request + ----------------------------------------------------------------------------------------- + PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL + PL_signals NEED_PL_signals NEED_PL_signals_GLOBAL + eval_pv() NEED_eval_pv NEED_eval_pv_GLOBAL + grok_bin() NEED_grok_bin NEED_grok_bin_GLOBAL + grok_hex() NEED_grok_hex NEED_grok_hex_GLOBAL + grok_number() NEED_grok_number NEED_grok_number_GLOBAL + grok_numeric_radix() NEED_grok_numeric_radix NEED_grok_numeric_radix_GLOBAL + grok_oct() NEED_grok_oct NEED_grok_oct_GLOBAL + load_module() NEED_load_module NEED_load_module_GLOBAL + my_snprintf() NEED_my_snprintf NEED_my_snprintf_GLOBAL + my_sprintf() NEED_my_sprintf NEED_my_sprintf_GLOBAL + my_strlcat() NEED_my_strlcat NEED_my_strlcat_GLOBAL + my_strlcpy() NEED_my_strlcpy NEED_my_strlcpy_GLOBAL + newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL + newRV_noinc() NEED_newRV_noinc NEED_newRV_noinc_GLOBAL + newSV_type() NEED_newSV_type NEED_newSV_type_GLOBAL + newSVpvn_flags() NEED_newSVpvn_flags NEED_newSVpvn_flags_GLOBAL + newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL + pv_display() NEED_pv_display NEED_pv_display_GLOBAL + pv_escape() NEED_pv_escape NEED_pv_escape_GLOBAL + pv_pretty() NEED_pv_pretty NEED_pv_pretty_GLOBAL + sv_2pv_flags() NEED_sv_2pv_flags NEED_sv_2pv_flags_GLOBAL + sv_2pvbyte() NEED_sv_2pvbyte NEED_sv_2pvbyte_GLOBAL + sv_catpvf_mg() NEED_sv_catpvf_mg NEED_sv_catpvf_mg_GLOBAL + sv_catpvf_mg_nocontext() NEED_sv_catpvf_mg_nocontext NEED_sv_catpvf_mg_nocontext_GLOBAL + sv_pvn_force_flags() NEED_sv_pvn_force_flags NEED_sv_pvn_force_flags_GLOBAL + sv_setpvf_mg() NEED_sv_setpvf_mg NEED_sv_setpvf_mg_GLOBAL + sv_setpvf_mg_nocontext() NEED_sv_setpvf_mg_nocontext NEED_sv_setpvf_mg_nocontext_GLOBAL + vload_module() NEED_vload_module NEED_vload_module_GLOBAL + vnewSVpvf() NEED_vnewSVpvf NEED_vnewSVpvf_GLOBAL + warner() NEED_warner NEED_warner_GLOBAL + +To avoid namespace conflicts, you can change the namespace of the +explicitly exported functions / variables using the C<DPPP_NAMESPACE> +macro. Just C<#define> the macro before including C<ppport.h>: + + #define DPPP_NAMESPACE MyOwnNamespace_ + #include "ppport.h" + +The default namespace is C<DPPP_>. + +=back + +The good thing is that most of the above can be checked by running +F<ppport.h> on your source code. See the next section for +details. + +=head1 EXAMPLES + +To verify whether F<ppport.h> is needed for your module, whether you +should make any changes to your code, and whether any special defines +should be used, F<ppport.h> can be run as a Perl script to check your +source code. Simply say: + + perl ppport.h + +The result will usually be a list of patches suggesting changes +that should at least be acceptable, if not necessarily the most +efficient solution, or a fix for all possible problems. + +If you know that your XS module uses features only available in +newer Perl releases, if you're aware that it uses C++ comments, +and if you want all suggestions as a single patch file, you could +use something like this: + + perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff + +If you only want your code to be scanned without any suggestions +for changes, use: + + perl ppport.h --nochanges + +You can specify a different C<diff> program or options, using +the C<--diff> option: + + perl ppport.h --diff='diff -C 10' + +This would output context diffs with 10 lines of context. + +If you want to create patched copies of your files instead, use: + + perl ppport.h --copy=.new + +To display portability information for the C<newSVpvn> function, +use: + + perl ppport.h --api-info=newSVpvn + +Since the argument to C<--api-info> can be a regular expression, +you can use + + perl ppport.h --api-info=/_nomg$/ + +to display portability information for all C<_nomg> functions or + + perl ppport.h --api-info=/./ + +to display information for all known API elements. + +=head1 BUGS + +If this version of F<ppport.h> is causing failure during +the compilation of this module, please check if newer versions +of either this module or C<Devel::PPPort> are available on CPAN +before sending a bug report. + +If F<ppport.h> was generated using the latest version of +C<Devel::PPPort> and is causing failure of this module, please +file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>. + +Please include the following information: + +=over 4 + +=item 1. + +The complete output from running "perl -V" + +=item 2. + +This file. + +=item 3. + +The name and version of the module you were trying to build. + +=item 4. + +A full log of the build that failed. + +=item 5. + +Any other information that you think could be relevant. + +=back + +For the latest version of this code, please get the C<Devel::PPPort> +module from CPAN. + +=head1 COPYRIGHT + +Version 3.x, Copyright (c) 2004-2009, Marcus Holland-Moritz. + +Version 2.x, Copyright (C) 2001, Paul Marquess. + +Version 1.x, Copyright (C) 1999, Kenneth Albanowski. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=head1 SEE ALSO + +See L<Devel::PPPort>. + +=cut + +use strict; + +# Disable broken TRIE-optimization +BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if $] >= 5.009004 && $] <= 5.009005 } + +my $VERSION = 3.19; + +my %opt = ( + quiet => 0, + diag => 1, + hints => 1, + changes => 1, + cplusplus => 0, + filter => 1, + strip => 0, + version => 0, +); + +my($ppport) = $0 =~ /([\w.]+)$/; +my $LF = '(?:\r\n|[\r\n])'; # line feed +my $HS = "[ \t]"; # horizontal whitespace + +# Never use C comments in this file! +my $ccs = '/'.'*'; +my $cce = '*'.'/'; +my $rccs = quotemeta $ccs; +my $rcce = quotemeta $cce; + +eval { + require Getopt::Long; + Getopt::Long::GetOptions(\%opt, qw( + help quiet diag! filter! hints! changes! cplusplus strip version + patch=s copy=s diff=s compat-version=s + list-provided list-unsupported api-info=s + )) or usage(); +}; + +if ($@ and grep /^-/, @ARGV) { + usage() if "@ARGV" =~ /^--?h(?:elp)?$/; + die "Getopt::Long not found. Please don't use any options.\n"; +} + +if ($opt{version}) { + print "This is $0 $VERSION.\n"; + exit 0; +} + +usage() if $opt{help}; +strip() if $opt{strip}; + +if (exists $opt{'compat-version'}) { + my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) }; + if ($@) { + die "Invalid version number format: '$opt{'compat-version'}'\n"; + } + die "Only Perl 5 is supported\n" if $r != 5; + die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000; + $opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s; +} +else { + $opt{'compat-version'} = 5; +} + +my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/ + ? ( $1 => { + ($2 ? ( base => $2 ) : ()), + ($3 ? ( todo => $3 ) : ()), + (index($4, 'v') >= 0 ? ( varargs => 1 ) : ()), + (index($4, 'p') >= 0 ? ( provided => 1 ) : ()), + (index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()), + } ) + : die "invalid spec: $_" } qw( +AvFILLp|5.004050||p +AvFILL||| +CLASS|||n +CPERLscope|5.005000||p +CX_CURPAD_SAVE||| +CX_CURPAD_SV||| +CopFILEAV|5.006000||p +CopFILEGV_set|5.006000||p +CopFILEGV|5.006000||p +CopFILESV|5.006000||p +CopFILE_set|5.006000||p +CopFILE|5.006000||p +CopSTASHPV_set|5.006000||p +CopSTASHPV|5.006000||p +CopSTASH_eq|5.006000||p +CopSTASH_set|5.006000||p +CopSTASH|5.006000||p +CopyD|5.009002||p +Copy||| +CvPADLIST||| +CvSTASH||| +CvWEAKOUTSIDE||| +DEFSV_set|5.011000||p +DEFSV|5.004050||p +END_EXTERN_C|5.005000||p +ENTER||| +ERRSV|5.004050||p +EXTEND||| +EXTERN_C|5.005000||p +F0convert|||n +FREETMPS||| +GIMME_V||5.004000|n +GIMME|||n +GROK_NUMERIC_RADIX|5.007002||p +G_ARRAY||| +G_DISCARD||| +G_EVAL||| +G_METHOD|5.006001||p +G_NOARGS||| +G_SCALAR||| +G_VOID||5.004000| +GetVars||| +GvSVn|5.009003||p +GvSV||| +Gv_AMupdate||| +HEf_SVKEY||5.004000| +HeHASH||5.004000| +HeKEY||5.004000| +HeKLEN||5.004000| +HePV||5.004000| +HeSVKEY_force||5.004000| +HeSVKEY_set||5.004000| +HeSVKEY||5.004000| +HeUTF8||5.011000| +HeVAL||5.004000| +HvNAMELEN_get|5.009003||p +HvNAME_get|5.009003||p +HvNAME||| +INT2PTR|5.006000||p +IN_LOCALE_COMPILETIME|5.007002||p +IN_LOCALE_RUNTIME|5.007002||p +IN_LOCALE|5.007002||p +IN_PERL_COMPILETIME|5.008001||p +IS_NUMBER_GREATER_THAN_UV_MAX|5.007002||p +IS_NUMBER_INFINITY|5.007002||p +IS_NUMBER_IN_UV|5.007002||p +IS_NUMBER_NAN|5.007003||p +IS_NUMBER_NEG|5.007002||p +IS_NUMBER_NOT_INT|5.007002||p +IVSIZE|5.006000||p +IVTYPE|5.006000||p +IVdf|5.006000||p +LEAVE||| +LVRET||| +MARK||| +MULTICALL||5.011000| +MY_CXT_CLONE|5.009002||p +MY_CXT_INIT|5.007003||p +MY_CXT|5.007003||p +MoveD|5.009002||p +Move||| +NOOP|5.005000||p +NUM2PTR|5.006000||p +NVTYPE|5.006000||p +NVef|5.006001||p +NVff|5.006001||p +NVgf|5.006001||p +Newxc|5.009003||p +Newxz|5.009003||p +Newx|5.009003||p +Nullav||| +Nullch||| +Nullcv||| +Nullhv||| +Nullsv||| +ORIGMARK||| +PAD_BASE_SV||| +PAD_CLONE_VARS||| +PAD_COMPNAME_FLAGS||| +PAD_COMPNAME_GEN_set||| +PAD_COMPNAME_GEN||| +PAD_COMPNAME_OURSTASH||| +PAD_COMPNAME_PV||| +PAD_COMPNAME_TYPE||| +PAD_DUP||| +PAD_RESTORE_LOCAL||| +PAD_SAVE_LOCAL||| +PAD_SAVE_SETNULLPAD||| +PAD_SETSV||| +PAD_SET_CUR_NOSAVE||| +PAD_SET_CUR||| +PAD_SVl||| +PAD_SV||| +PERLIO_FUNCS_CAST|5.009003||p +PERLIO_FUNCS_DECL|5.009003||p +PERL_ABS|5.008001||p +PERL_BCDVERSION|5.011000||p +PERL_GCC_BRACE_GROUPS_FORBIDDEN|5.008001||p +PERL_HASH|5.004000||p +PERL_INT_MAX|5.004000||p +PERL_INT_MIN|5.004000||p +PERL_LONG_MAX|5.004000||p +PERL_LONG_MIN|5.004000||p +PERL_MAGIC_arylen|5.007002||p +PERL_MAGIC_backref|5.007002||p +PERL_MAGIC_bm|5.007002||p +PERL_MAGIC_collxfrm|5.007002||p +PERL_MAGIC_dbfile|5.007002||p +PERL_MAGIC_dbline|5.007002||p +PERL_MAGIC_defelem|5.007002||p +PERL_MAGIC_envelem|5.007002||p +PERL_MAGIC_env|5.007002||p +PERL_MAGIC_ext|5.007002||p +PERL_MAGIC_fm|5.007002||p +PERL_MAGIC_glob|5.011000||p +PERL_MAGIC_isaelem|5.007002||p +PERL_MAGIC_isa|5.007002||p +PERL_MAGIC_mutex|5.011000||p +PERL_MAGIC_nkeys|5.007002||p +PERL_MAGIC_overload_elem|5.007002||p +PERL_MAGIC_overload_table|5.007002||p +PERL_MAGIC_overload|5.007002||p +PERL_MAGIC_pos|5.007002||p +PERL_MAGIC_qr|5.007002||p +PERL_MAGIC_regdata|5.007002||p +PERL_MAGIC_regdatum|5.007002||p +PERL_MAGIC_regex_global|5.007002||p +PERL_MAGIC_shared_scalar|5.007003||p +PERL_MAGIC_shared|5.007003||p +PERL_MAGIC_sigelem|5.007002||p +PERL_MAGIC_sig|5.007002||p +PERL_MAGIC_substr|5.007002||p +PERL_MAGIC_sv|5.007002||p +PERL_MAGIC_taint|5.007002||p +PERL_MAGIC_tiedelem|5.007002||p +PERL_MAGIC_tiedscalar|5.007002||p +PERL_MAGIC_tied|5.007002||p +PERL_MAGIC_utf8|5.008001||p +PERL_MAGIC_uvar_elem|5.007003||p +PERL_MAGIC_uvar|5.007002||p +PERL_MAGIC_vec|5.007002||p +PERL_MAGIC_vstring|5.008001||p +PERL_PV_ESCAPE_ALL|5.009004||p +PERL_PV_ESCAPE_FIRSTCHAR|5.009004||p +PERL_PV_ESCAPE_NOBACKSLASH|5.009004||p +PERL_PV_ESCAPE_NOCLEAR|5.009004||p +PERL_PV_ESCAPE_QUOTE|5.009004||p +PERL_PV_ESCAPE_RE|5.009005||p +PERL_PV_ESCAPE_UNI_DETECT|5.009004||p +PERL_PV_ESCAPE_UNI|5.009004||p +PERL_PV_PRETTY_DUMP|5.009004||p +PERL_PV_PRETTY_ELLIPSES|5.010000||p +PERL_PV_PRETTY_LTGT|5.009004||p +PERL_PV_PRETTY_NOCLEAR|5.010000||p +PERL_PV_PRETTY_QUOTE|5.009004||p +PERL_PV_PRETTY_REGPROP|5.009004||p +PERL_QUAD_MAX|5.004000||p +PERL_QUAD_MIN|5.004000||p +PERL_REVISION|5.006000||p +PERL_SCAN_ALLOW_UNDERSCORES|5.007003||p +PERL_SCAN_DISALLOW_PREFIX|5.007003||p +PERL_SCAN_GREATER_THAN_UV_MAX|5.007003||p +PERL_SCAN_SILENT_ILLDIGIT|5.008001||p +PERL_SHORT_MAX|5.004000||p +PERL_SHORT_MIN|5.004000||p +PERL_SIGNALS_UNSAFE_FLAG|5.008001||p +PERL_SUBVERSION|5.006000||p +PERL_SYS_INIT3||5.006000| +PERL_SYS_INIT||| +PERL_SYS_TERM||5.011000| +PERL_UCHAR_MAX|5.004000||p +PERL_UCHAR_MIN|5.004000||p +PERL_UINT_MAX|5.004000||p +PERL_UINT_MIN|5.004000||p +PERL_ULONG_MAX|5.004000||p +PERL_ULONG_MIN|5.004000||p +PERL_UNUSED_ARG|5.009003||p +PERL_UNUSED_CONTEXT|5.009004||p +PERL_UNUSED_DECL|5.007002||p +PERL_UNUSED_VAR|5.007002||p +PERL_UQUAD_MAX|5.004000||p +PERL_UQUAD_MIN|5.004000||p +PERL_USE_GCC_BRACE_GROUPS|5.009004||p +PERL_USHORT_MAX|5.004000||p +PERL_USHORT_MIN|5.004000||p +PERL_VERSION|5.006000||p +PL_DBsignal|5.005000||p +PL_DBsingle|||pn +PL_DBsub|||pn +PL_DBtrace|||pn +PL_Sv|5.005000||p +PL_bufend|5.011000||p +PL_bufptr|5.011000||p +PL_compiling|5.004050||p +PL_copline|5.011000||p +PL_curcop|5.004050||p +PL_curstash|5.004050||p +PL_debstash|5.004050||p +PL_defgv|5.004050||p +PL_diehook|5.004050||p +PL_dirty|5.004050||p +PL_dowarn|||pn +PL_errgv|5.004050||p +PL_error_count|5.011000||p +PL_expect|5.011000||p +PL_hexdigit|5.005000||p +PL_hints|5.005000||p +PL_in_my_stash|5.011000||p +PL_in_my|5.011000||p +PL_last_in_gv|||n +PL_laststatval|5.005000||p +PL_lex_state|5.011000||p +PL_lex_stuff|5.011000||p +PL_linestr|5.011000||p +PL_modglobal||5.005000|n +PL_na|5.004050||pn +PL_no_modify|5.006000||p +PL_ofsgv|||n +PL_parser|5.009005||p +PL_perl_destruct_level|5.004050||p +PL_perldb|5.004050||p +PL_ppaddr|5.006000||p +PL_rsfp_filters|5.004050||p +PL_rsfp|5.004050||p +PL_rs|||n +PL_signals|5.008001||p +PL_stack_base|5.004050||p +PL_stack_sp|5.004050||p +PL_statcache|5.005000||p +PL_stdingv|5.004050||p +PL_sv_arenaroot|5.004050||p +PL_sv_no|5.004050||pn +PL_sv_undef|5.004050||pn +PL_sv_yes|5.004050||pn +PL_tainted|5.004050||p +PL_tainting|5.004050||p +PL_tokenbuf|5.011000||p +POP_MULTICALL||5.011000| +POPi|||n +POPl|||n +POPn|||n +POPpbytex||5.007001|n +POPpx||5.005030|n +POPp|||n +POPs|||n +PTR2IV|5.006000||p +PTR2NV|5.006000||p +PTR2UV|5.006000||p +PTR2nat|5.009003||p +PTR2ul|5.007001||p +PTRV|5.006000||p +PUSHMARK||| +PUSH_MULTICALL||5.011000| +PUSHi||| +PUSHmortal|5.009002||p +PUSHn||| +PUSHp||| +PUSHs||| +PUSHu|5.004000||p +PUTBACK||| +PerlIO_clearerr||5.007003| +PerlIO_close||5.007003| +PerlIO_context_layers||5.009004| +PerlIO_eof||5.007003| +PerlIO_error||5.007003| +PerlIO_fileno||5.007003| +PerlIO_fill||5.007003| +PerlIO_flush||5.007003| +PerlIO_get_base||5.007003| +PerlIO_get_bufsiz||5.007003| +PerlIO_get_cnt||5.007003| +PerlIO_get_ptr||5.007003| +PerlIO_read||5.007003| +PerlIO_seek||5.007003| +PerlIO_set_cnt||5.007003| +PerlIO_set_ptrcnt||5.007003| +PerlIO_setlinebuf||5.007003| +PerlIO_stderr||5.007003| +PerlIO_stdin||5.007003| +PerlIO_stdout||5.007003| +PerlIO_tell||5.007003| +PerlIO_unread||5.007003| +PerlIO_write||5.007003| +Perl_signbit||5.009005|n +PoisonFree|5.009004||p +PoisonNew|5.009004||p +PoisonWith|5.009004||p +Poison|5.008000||p +RETVAL|||n +Renewc||| +Renew||| +SAVECLEARSV||| +SAVECOMPPAD||| +SAVEPADSV||| +SAVETMPS||| +SAVE_DEFSV|5.004050||p +SPAGAIN||| +SP||| +START_EXTERN_C|5.005000||p +START_MY_CXT|5.007003||p +STMT_END|||p +STMT_START|||p +STR_WITH_LEN|5.009003||p +ST||| +SV_CONST_RETURN|5.009003||p +SV_COW_DROP_PV|5.008001||p +SV_COW_SHARED_HASH_KEYS|5.009005||p +SV_GMAGIC|5.007002||p +SV_HAS_TRAILING_NUL|5.009004||p +SV_IMMEDIATE_UNREF|5.007001||p +SV_MUTABLE_RETURN|5.009003||p +SV_NOSTEAL|5.009002||p +SV_SMAGIC|5.009003||p +SV_UTF8_NO_ENCODING|5.008001||p +SVfARG|5.009005||p +SVf_UTF8|5.006000||p +SVf|5.006000||p +SVt_IV||| +SVt_NV||| +SVt_PVAV||| +SVt_PVCV||| +SVt_PVHV||| +SVt_PVMG||| +SVt_PV||| +Safefree||| +Slab_Alloc||| +Slab_Free||| +Slab_to_rw||| +StructCopy||| +SvCUR_set||| +SvCUR||| +SvEND||| +SvGAMAGIC||5.006001| +SvGETMAGIC|5.004050||p +SvGROW||| +SvIOK_UV||5.006000| +SvIOK_notUV||5.006000| +SvIOK_off||| +SvIOK_only_UV||5.006000| +SvIOK_only||| +SvIOK_on||| +SvIOKp||| +SvIOK||| +SvIVX||| +SvIV_nomg|5.009001||p +SvIV_set||| +SvIVx||| +SvIV||| +SvIsCOW_shared_hash||5.008003| +SvIsCOW||5.008003| +SvLEN_set||| +SvLEN||| +SvLOCK||5.007003| +SvMAGIC_set|5.009003||p +SvNIOK_off||| +SvNIOKp||| +SvNIOK||| +SvNOK_off||| +SvNOK_only||| +SvNOK_on||| +SvNOKp||| +SvNOK||| +SvNVX||| +SvNV_set||| +SvNVx||| +SvNV||| +SvOK||| +SvOOK_offset||5.011000| +SvOOK||| +SvPOK_off||| +SvPOK_only_UTF8||5.006000| +SvPOK_only||| +SvPOK_on||| +SvPOKp||| +SvPOK||| +SvPVX_const|5.009003||p +SvPVX_mutable|5.009003||p +SvPVX||| +SvPV_const|5.009003||p +SvPV_flags_const_nolen|5.009003||p +SvPV_flags_const|5.009003||p +SvPV_flags_mutable|5.009003||p +SvPV_flags|5.007002||p +SvPV_force_flags_mutable|5.009003||p +SvPV_force_flags_nolen|5.009003||p +SvPV_force_flags|5.007002||p +SvPV_force_mutable|5.009003||p +SvPV_force_nolen|5.009003||p +SvPV_force_nomg_nolen|5.009003||p +SvPV_force_nomg|5.007002||p +SvPV_force|||p +SvPV_mutable|5.009003||p +SvPV_nolen_const|5.009003||p +SvPV_nolen|5.006000||p +SvPV_nomg_const_nolen|5.009003||p +SvPV_nomg_const|5.009003||p +SvPV_nomg|5.007002||p +SvPV_renew|5.009003||p +SvPV_set||| +SvPVbyte_force||5.009002| +SvPVbyte_nolen||5.006000| +SvPVbytex_force||5.006000| +SvPVbytex||5.006000| +SvPVbyte|5.006000||p +SvPVutf8_force||5.006000| +SvPVutf8_nolen||5.006000| +SvPVutf8x_force||5.006000| +SvPVutf8x||5.006000| +SvPVutf8||5.006000| +SvPVx||| +SvPV||| +SvREFCNT_dec||| +SvREFCNT_inc_NN|5.009004||p +SvREFCNT_inc_simple_NN|5.009004||p +SvREFCNT_inc_simple_void_NN|5.009004||p +SvREFCNT_inc_simple_void|5.009004||p +SvREFCNT_inc_simple|5.009004||p +SvREFCNT_inc_void_NN|5.009004||p +SvREFCNT_inc_void|5.009004||p +SvREFCNT_inc|||p +SvREFCNT||| +SvROK_off||| +SvROK_on||| +SvROK||| +SvRV_set|5.009003||p +SvRV||| +SvRXOK||5.009005| +SvRX||5.009005| +SvSETMAGIC||| +SvSHARED_HASH|5.009003||p +SvSHARE||5.007003| +SvSTASH_set|5.009003||p +SvSTASH||| +SvSetMagicSV_nosteal||5.004000| +SvSetMagicSV||5.004000| +SvSetSV_nosteal||5.004000| +SvSetSV||| +SvTAINTED_off||5.004000| +SvTAINTED_on||5.004000| +SvTAINTED||5.004000| +SvTAINT||| +SvTRUE||| +SvTYPE||| +SvUNLOCK||5.007003| +SvUOK|5.007001|5.006000|p +SvUPGRADE||| +SvUTF8_off||5.006000| +SvUTF8_on||5.006000| +SvUTF8||5.006000| +SvUVXx|5.004000||p +SvUVX|5.004000||p +SvUV_nomg|5.009001||p +SvUV_set|5.009003||p +SvUVx|5.004000||p +SvUV|5.004000||p +SvVOK||5.008001| +SvVSTRING_mg|5.009004||p +THIS|||n +UNDERBAR|5.009002||p +UTF8_MAXBYTES|5.009002||p +UVSIZE|5.006000||p +UVTYPE|5.006000||p +UVXf|5.007001||p +UVof|5.006000||p +UVuf|5.006000||p +UVxf|5.006000||p +WARN_ALL|5.006000||p +WARN_AMBIGUOUS|5.006000||p +WARN_ASSERTIONS|5.011000||p +WARN_BAREWORD|5.006000||p +WARN_CLOSED|5.006000||p +WARN_CLOSURE|5.006000||p +WARN_DEBUGGING|5.006000||p +WARN_DEPRECATED|5.006000||p +WARN_DIGIT|5.006000||p +WARN_EXEC|5.006000||p +WARN_EXITING|5.006000||p +WARN_GLOB|5.006000||p +WARN_INPLACE|5.006000||p +WARN_INTERNAL|5.006000||p +WARN_IO|5.006000||p +WARN_LAYER|5.008000||p +WARN_MALLOC|5.006000||p +WARN_MISC|5.006000||p +WARN_NEWLINE|5.006000||p +WARN_NUMERIC|5.006000||p +WARN_ONCE|5.006000||p +WARN_OVERFLOW|5.006000||p +WARN_PACK|5.006000||p +WARN_PARENTHESIS|5.006000||p +WARN_PIPE|5.006000||p +WARN_PORTABLE|5.006000||p +WARN_PRECEDENCE|5.006000||p +WARN_PRINTF|5.006000||p +WARN_PROTOTYPE|5.006000||p +WARN_QW|5.006000||p +WARN_RECURSION|5.006000||p +WARN_REDEFINE|5.006000||p +WARN_REGEXP|5.006000||p +WARN_RESERVED|5.006000||p +WARN_SEMICOLON|5.006000||p +WARN_SEVERE|5.006000||p +WARN_SIGNAL|5.006000||p +WARN_SUBSTR|5.006000||p +WARN_SYNTAX|5.006000||p +WARN_TAINT|5.006000||p +WARN_THREADS|5.008000||p +WARN_UNINITIALIZED|5.006000||p +WARN_UNOPENED|5.006000||p +WARN_UNPACK|5.006000||p +WARN_UNTIE|5.006000||p +WARN_UTF8|5.006000||p +WARN_VOID|5.006000||p +XCPT_CATCH|5.009002||p +XCPT_RETHROW|5.009002||p +XCPT_TRY_END|5.009002||p +XCPT_TRY_START|5.009002||p +XPUSHi||| +XPUSHmortal|5.009002||p +XPUSHn||| +XPUSHp||| +XPUSHs||| +XPUSHu|5.004000||p +XSPROTO|5.010000||p +XSRETURN_EMPTY||| +XSRETURN_IV||| +XSRETURN_NO||| +XSRETURN_NV||| +XSRETURN_PV||| +XSRETURN_UNDEF||| +XSRETURN_UV|5.008001||p +XSRETURN_YES||| +XSRETURN|||p +XST_mIV||| +XST_mNO||| +XST_mNV||| +XST_mPV||| +XST_mUNDEF||| +XST_mUV|5.008001||p +XST_mYES||| +XS_VERSION_BOOTCHECK||| +XS_VERSION||| +XSprePUSH|5.006000||p +XS||| +ZeroD|5.009002||p +Zero||| +_aMY_CXT|5.007003||p +_pMY_CXT|5.007003||p +aMY_CXT_|5.007003||p +aMY_CXT|5.007003||p +aTHXR_|5.011000||p +aTHXR|5.011000||p +aTHX_|5.006000||p +aTHX|5.006000||p +add_data|||n +addmad||| +allocmy||| +amagic_call||| +amagic_cmp_locale||| +amagic_cmp||| +amagic_i_ncmp||| +amagic_ncmp||| +any_dup||| +ao||| +append_elem||| +append_list||| +append_madprops||| +apply_attrs_my||| +apply_attrs_string||5.006001| +apply_attrs||| +apply||| +atfork_lock||5.007003|n +atfork_unlock||5.007003|n +av_arylen_p||5.009003| +av_clear||| +av_create_and_push||5.009005| +av_create_and_unshift_one||5.009005| +av_delete||5.006000| +av_exists||5.006000| +av_extend||| +av_fetch||| +av_fill||| +av_iter_p||5.011000| +av_len||| +av_make||| +av_pop||| +av_push||| +av_reify||| +av_shift||| +av_store||| +av_undef||| +av_unshift||| +ax|||n +bad_type||| +bind_match||| +block_end||| +block_gimme||5.004000| +block_start||| +boolSV|5.004000||p +boot_core_PerlIO||| +boot_core_UNIVERSAL||| +boot_core_mro||| +bytes_from_utf8||5.007001| +bytes_to_uni|||n +bytes_to_utf8||5.006001| +call_argv|5.006000||p +call_atexit||5.006000| +call_list||5.004000| +call_method|5.006000||p +call_pv|5.006000||p +call_sv|5.006000||p +calloc||5.007002|n +cando||| +cast_i32||5.006000| +cast_iv||5.006000| +cast_ulong||5.006000| +cast_uv||5.006000| +check_type_and_open||| +check_uni||| +checkcomma||| +checkposixcc||| +ckWARN|5.006000||p +ck_anoncode||| +ck_bitop||| +ck_concat||| +ck_defined||| +ck_delete||| +ck_die||| +ck_each||| +ck_eof||| +ck_eval||| +ck_exec||| +ck_exists||| +ck_exit||| +ck_ftst||| +ck_fun||| +ck_glob||| +ck_grep||| +ck_index||| +ck_join||| +ck_lfun||| +ck_listiob||| +ck_match||| +ck_method||| +ck_null||| +ck_open||| +ck_readline||| +ck_repeat||| +ck_require||| +ck_return||| +ck_rfun||| +ck_rvconst||| +ck_sassign||| +ck_select||| +ck_shift||| +ck_sort||| +ck_spair||| +ck_split||| +ck_subr||| +ck_substr||| +ck_svconst||| +ck_trunc||| +ck_unpack||| +ckwarn_d||5.009003| +ckwarn||5.009003| +cl_and|||n +cl_anything|||n +cl_init_zero|||n +cl_init|||n +cl_is_anything|||n +cl_or|||n +clear_placeholders||| +closest_cop||| +convert||| +cop_free||| +cr_textfilter||| +create_eval_scope||| +croak_nocontext|||vn +croak_xs_usage||5.011000| +croak|||v +csighandler||5.009003|n +curmad||| +custom_op_desc||5.007003| +custom_op_name||5.007003| +cv_ckproto_len||| +cv_clone||| +cv_const_sv||5.004000| +cv_dump||| +cv_undef||| +cx_dump||5.005000| +cx_dup||| +cxinc||| +dAXMARK|5.009003||p +dAX|5.007002||p +dITEMS|5.007002||p +dMARK||| +dMULTICALL||5.009003| +dMY_CXT_SV|5.007003||p +dMY_CXT|5.007003||p +dNOOP|5.006000||p +dORIGMARK||| +dSP||| +dTHR|5.004050||p +dTHXR|5.011000||p +dTHXa|5.006000||p +dTHXoa|5.006000||p +dTHX|5.006000||p +dUNDERBAR|5.009002||p +dVAR|5.009003||p +dXCPT|5.009002||p +dXSARGS||| +dXSI32||| +dXSTARG|5.006000||p +deb_curcv||| +deb_nocontext|||vn +deb_stack_all||| +deb_stack_n||| +debop||5.005000| +debprofdump||5.005000| +debprof||| +debstackptrs||5.007003| +debstack||5.007003| +debug_start_match||| +deb||5.007003|v +del_sv||| +delete_eval_scope||| +delimcpy||5.004000| +deprecate_old||| +deprecate||| +despatch_signals||5.007001| +destroy_matcher||| +die_nocontext|||vn +die_where||| +die|||v +dirp_dup||| +div128||| +djSP||| +do_aexec5||| +do_aexec||| +do_aspawn||| +do_binmode||5.004050| +do_chomp||| +do_chop||| +do_close||| +do_dump_pad||| +do_eof||| +do_exec3||| +do_execfree||| +do_exec||| +do_gv_dump||5.006000| +do_gvgv_dump||5.006000| +do_hv_dump||5.006000| +do_ipcctl||| +do_ipcget||| +do_join||| +do_kv||| +do_magic_dump||5.006000| +do_msgrcv||| +do_msgsnd||| +do_oddball||| +do_op_dump||5.006000| +do_op_xmldump||| +do_open9||5.006000| +do_openn||5.007001| +do_open||5.004000| +do_pmop_dump||5.006000| +do_pmop_xmldump||| +do_print||| +do_readline||| +do_seek||| +do_semop||| +do_shmio||| +do_smartmatch||| +do_spawn_nowait||| +do_spawn||| +do_sprintf||| +do_sv_dump||5.006000| +do_sysseek||| +do_tell||| +do_trans_complex_utf8||| +do_trans_complex||| +do_trans_count_utf8||| +do_trans_count||| +do_trans_simple_utf8||| +do_trans_simple||| +do_trans||| +do_vecget||| +do_vecset||| +do_vop||| +docatch||| +doeval||| +dofile||| +dofindlabel||| +doform||| +doing_taint||5.008001|n +dooneliner||| +doopen_pm||| +doparseform||| +dopoptoeval||| +dopoptogiven||| +dopoptolabel||| +dopoptoloop||| +dopoptosub_at||| +dopoptowhen||| +doref||5.009003| +dounwind||| +dowantarray||| +dump_all||5.006000| +dump_eval||5.006000| +dump_exec_pos||| +dump_fds||| +dump_form||5.006000| +dump_indent||5.006000|v +dump_mstats||| +dump_packsubs||5.006000| +dump_sub||5.006000| +dump_sv_child||| +dump_trie_interim_list||| +dump_trie_interim_table||| +dump_trie||| +dump_vindent||5.006000| +dumpuntil||| +dup_attrlist||| +emulate_cop_io||| +eval_pv|5.006000||p +eval_sv|5.006000||p +exec_failed||| +expect_number||| +fbm_compile||5.005000| +fbm_instr||5.005000| +feature_is_enabled||| +fetch_cop_label||5.011000| +filter_add||| +filter_del||| +filter_gets||| +filter_read||| +find_and_forget_pmops||| +find_array_subscript||| +find_beginning||| +find_byclass||| +find_hash_subscript||| +find_in_my_stash||| +find_runcv||5.008001| +find_rundefsvoffset||5.009002| +find_script||| +find_uninit_var||| +first_symbol|||n +fold_constants||| +forbid_setid||| +force_ident||| +force_list||| +force_next||| +force_version||| +force_word||| +forget_pmop||| +form_nocontext|||vn +form||5.004000|v +fp_dup||| +fprintf_nocontext|||vn +free_global_struct||| +free_tied_hv_pool||| +free_tmps||| +gen_constant_list||| +get_arena||| +get_aux_mg||| +get_av|5.006000||p +get_context||5.006000|n +get_cvn_flags||5.009005| +get_cv|5.006000||p +get_db_sub||| +get_debug_opts||| +get_hash_seed||| +get_hv|5.006000||p +get_isa_hash||| +get_mstats||| +get_no_modify||| +get_num||| +get_op_descs||5.005000| +get_op_names||5.005000| +get_opargs||| +get_ppaddr||5.006000| +get_re_arg||| +get_sv|5.006000||p +get_vtbl||5.005030| +getcwd_sv||5.007002| +getenv_len||| +glob_2number||| +glob_assign_glob||| +glob_assign_ref||| +gp_dup||| +gp_free||| +gp_ref||| +grok_bin|5.007003||p +grok_hex|5.007003||p +grok_number|5.007002||p +grok_numeric_radix|5.007002||p +grok_oct|5.007003||p +group_end||| +gv_AVadd||| +gv_HVadd||| +gv_IOadd||| +gv_SVadd||| +gv_autoload4||5.004000| +gv_check||| +gv_const_sv||5.009003| +gv_dump||5.006000| +gv_efullname3||5.004000| +gv_efullname4||5.006001| +gv_efullname||| +gv_ename||| +gv_fetchfile_flags||5.009005| +gv_fetchfile||| +gv_fetchmeth_autoload||5.007003| +gv_fetchmethod_autoload||5.004000| +gv_fetchmethod_flags||5.011000| +gv_fetchmethod||| +gv_fetchmeth||| +gv_fetchpvn_flags|5.009002||p +gv_fetchpvs|5.009004||p +gv_fetchpv||| +gv_fetchsv||5.009002| +gv_fullname3||5.004000| +gv_fullname4||5.006001| +gv_fullname||| +gv_get_super_pkg||| +gv_handler||5.007001| +gv_init_sv||| +gv_init||| +gv_name_set||5.009004| +gv_stashpvn|5.004000||p +gv_stashpvs|5.009003||p +gv_stashpv||| +gv_stashsv||| +he_dup||| +hek_dup||| +hfreeentries||| +hsplit||| +hv_assert||5.011000| +hv_auxinit|||n +hv_backreferences_p||| +hv_clear_placeholders||5.009001| +hv_clear||| +hv_common_key_len||5.010000| +hv_common||5.010000| +hv_copy_hints_hv||| +hv_delayfree_ent||5.004000| +hv_delete_common||| +hv_delete_ent||5.004000| +hv_delete||| +hv_eiter_p||5.009003| +hv_eiter_set||5.009003| +hv_exists_ent||5.004000| +hv_exists||| +hv_fetch_ent||5.004000| +hv_fetchs|5.009003||p +hv_fetch||| +hv_free_ent||5.004000| +hv_iterinit||| +hv_iterkeysv||5.004000| +hv_iterkey||| +hv_iternext_flags||5.008000| +hv_iternextsv||| +hv_iternext||| +hv_iterval||| +hv_kill_backrefs||| +hv_ksplit||5.004000| +hv_magic_check|||n +hv_magic||| +hv_name_set||5.009003| +hv_notallowed||| +hv_placeholders_get||5.009003| +hv_placeholders_p||5.009003| +hv_placeholders_set||5.009003| +hv_riter_p||5.009003| +hv_riter_set||5.009003| +hv_scalar||5.009001| +hv_store_ent||5.004000| +hv_store_flags||5.008000| +hv_stores|5.009004||p +hv_store||| +hv_undef||| +ibcmp_locale||5.004000| +ibcmp_utf8||5.007003| +ibcmp||| +incline||| +incpush_if_exists||| +incpush_use_sep||| +incpush||| +ingroup||| +init_argv_symbols||| +init_debugger||| +init_global_struct||| +init_i18nl10n||5.006000| +init_i18nl14n||5.006000| +init_ids||| +init_interp||| +init_main_stash||| +init_perllib||| +init_postdump_symbols||| +init_predump_symbols||| +init_stacks||5.005000| +init_tm||5.007002| +instr||| +intro_my||| +intuit_method||| +intuit_more||| +invert||| +io_close||| +isALNUMC|5.006000||p +isALNUM||| +isALPHA||| +isASCII|5.006000||p +isBLANK|5.006001||p +isCNTRL|5.006000||p +isDIGIT||| +isGRAPH|5.006000||p +isGV_with_GP|5.009004||p +isLOWER||| +isPRINT|5.004000||p +isPSXSPC|5.006001||p +isPUNCT|5.006000||p +isSPACE||| +isUPPER||| +isXDIGIT|5.006000||p +is_an_int||| +is_gv_magical_sv||| +is_handle_constructor|||n +is_list_assignment||| +is_lvalue_sub||5.007001| +is_uni_alnum_lc||5.006000| +is_uni_alnumc_lc||5.006000| +is_uni_alnumc||5.006000| +is_uni_alnum||5.006000| +is_uni_alpha_lc||5.006000| +is_uni_alpha||5.006000| +is_uni_ascii_lc||5.006000| +is_uni_ascii||5.006000| +is_uni_cntrl_lc||5.006000| +is_uni_cntrl||5.006000| +is_uni_digit_lc||5.006000| +is_uni_digit||5.006000| +is_uni_graph_lc||5.006000| +is_uni_graph||5.006000| +is_uni_idfirst_lc||5.006000| +is_uni_idfirst||5.006000| +is_uni_lower_lc||5.006000| +is_uni_lower||5.006000| +is_uni_print_lc||5.006000| +is_uni_print||5.006000| +is_uni_punct_lc||5.006000| +is_uni_punct||5.006000| +is_uni_space_lc||5.006000| +is_uni_space||5.006000| +is_uni_upper_lc||5.006000| +is_uni_upper||5.006000| +is_uni_xdigit_lc||5.006000| +is_uni_xdigit||5.006000| +is_utf8_alnumc||5.006000| +is_utf8_alnum||5.006000| +is_utf8_alpha||5.006000| +is_utf8_ascii||5.006000| +is_utf8_char_slow|||n +is_utf8_char||5.006000| +is_utf8_cntrl||5.006000| +is_utf8_common||| +is_utf8_digit||5.006000| +is_utf8_graph||5.006000| +is_utf8_idcont||5.008000| +is_utf8_idfirst||5.006000| +is_utf8_lower||5.006000| +is_utf8_mark||5.006000| +is_utf8_print||5.006000| +is_utf8_punct||5.006000| +is_utf8_space||5.006000| +is_utf8_string_loclen||5.009003| +is_utf8_string_loc||5.008001| +is_utf8_string||5.006001| +is_utf8_upper||5.006000| +is_utf8_xdigit||5.006000| +isa_lookup||| +items|||n +ix|||n +jmaybe||| +join_exact||| +keyword||| +leave_scope||| +lex_end||| +lex_start||| +linklist||| +listkids||| +list||| +load_module_nocontext|||vn +load_module|5.006000||pv +localize||| +looks_like_bool||| +looks_like_number||| +lop||| +mPUSHi|5.009002||p +mPUSHn|5.009002||p +mPUSHp|5.009002||p +mPUSHs|5.011000||p +mPUSHu|5.009002||p +mXPUSHi|5.009002||p +mXPUSHn|5.009002||p +mXPUSHp|5.009002||p +mXPUSHs|5.011000||p +mXPUSHu|5.009002||p +mad_free||| +madlex||| +madparse||| +magic_clear_all_env||| +magic_clearenv||| +magic_clearhint||| +magic_clearisa||| +magic_clearpack||| +magic_clearsig||| +magic_dump||5.006000| +magic_existspack||| +magic_freearylen_p||| +magic_freeovrld||| +magic_getarylen||| +magic_getdefelem||| +magic_getnkeys||| +magic_getpack||| +magic_getpos||| +magic_getsig||| +magic_getsubstr||| +magic_gettaint||| +magic_getuvar||| +magic_getvec||| +magic_get||| +magic_killbackrefs||| +magic_len||| +magic_methcall||| +magic_methpack||| +magic_nextpack||| +magic_regdata_cnt||| +magic_regdatum_get||| +magic_regdatum_set||| +magic_scalarpack||| +magic_set_all_env||| +magic_setamagic||| +magic_setarylen||| +magic_setcollxfrm||| +magic_setdbline||| +magic_setdefelem||| +magic_setenv||| +magic_sethint||| +magic_setisa||| +magic_setmglob||| +magic_setnkeys||| +magic_setpack||| +magic_setpos||| +magic_setregexp||| +magic_setsig||| +magic_setsubstr||| +magic_settaint||| +magic_setutf8||| +magic_setuvar||| +magic_setvec||| +magic_set||| +magic_sizepack||| +magic_wipepack||| +make_matcher||| +make_trie_failtable||| +make_trie||| +malloc_good_size|||n +malloced_size|||n +malloc||5.007002|n +markstack_grow||| +matcher_matches_sv||| +measure_struct||| +memEQ|5.004000||p +memNE|5.004000||p +mem_collxfrm||| +mem_log_common|||n +mess_alloc||| +mess_nocontext|||vn +mess||5.006000|v +method_common||| +mfree||5.007002|n +mg_clear||| +mg_copy||| +mg_dup||| +mg_find||| +mg_free||| +mg_get||| +mg_length||5.005000| +mg_localize||| +mg_magical||| +mg_set||| +mg_size||5.005000| +mini_mktime||5.007002| +missingterm||| +mode_from_discipline||| +modkids||| +mod||| +more_bodies||| +more_sv||| +moreswitches||| +mro_get_from_name||5.011000| +mro_get_linear_isa_dfs||| +mro_get_linear_isa||5.009005| +mro_get_private_data||5.011000| +mro_isa_changed_in||| +mro_meta_dup||| +mro_meta_init||| +mro_method_changed_in||5.009005| +mro_register||5.011000| +mro_set_mro||5.011000| +mro_set_private_data||5.011000| +mul128||| +mulexp10|||n +my_atof2||5.007002| +my_atof||5.006000| +my_attrs||| +my_bcopy|||n +my_betoh16|||n +my_betoh32|||n +my_betoh64|||n +my_betohi|||n +my_betohl|||n +my_betohs|||n +my_bzero|||n +my_chsize||| +my_clearenv||| +my_cxt_index||| +my_cxt_init||| +my_dirfd||5.009005| +my_exit_jump||| +my_exit||| +my_failure_exit||5.004000| +my_fflush_all||5.006000| +my_fork||5.007003|n +my_htobe16|||n +my_htobe32|||n +my_htobe64|||n +my_htobei|||n +my_htobel|||n +my_htobes|||n +my_htole16|||n +my_htole32|||n +my_htole64|||n +my_htolei|||n +my_htolel|||n +my_htoles|||n +my_htonl||| +my_kid||| +my_letoh16|||n +my_letoh32|||n +my_letoh64|||n +my_letohi|||n +my_letohl|||n +my_letohs|||n +my_lstat||| +my_memcmp||5.004000|n +my_memset|||n +my_ntohl||| +my_pclose||5.004000| +my_popen_list||5.007001| +my_popen||5.004000| +my_setenv||| +my_snprintf|5.009004||pvn +my_socketpair||5.007003|n +my_sprintf|5.009003||pvn +my_stat||| +my_strftime||5.007002| +my_strlcat|5.009004||pn +my_strlcpy|5.009004||pn +my_swabn|||n +my_swap||| +my_unexec||| +my_vsnprintf||5.009004|n +need_utf8|||n +newANONATTRSUB||5.006000| +newANONHASH||| +newANONLIST||| +newANONSUB||| +newASSIGNOP||| +newATTRSUB||5.006000| +newAVREF||| +newAV||| +newBINOP||| +newCONDOP||| +newCONSTSUB|5.004050||p +newCVREF||| +newDEFSVOP||| +newFORM||| +newFOROP||| +newGIVENOP||5.009003| +newGIVWHENOP||| +newGP||| +newGVOP||| +newGVREF||| +newGVgen||| +newHVREF||| +newHVhv||5.005000| +newHV||| +newIO||| +newLISTOP||| +newLOGOP||| +newLOOPEX||| +newLOOPOP||| +newMADPROP||| +newMADsv||| +newMYSUB||| +newNULLLIST||| +newOP||| +newPADOP||| +newPMOP||| +newPROG||| +newPVOP||| +newRANGE||| +newRV_inc|5.004000||p +newRV_noinc|5.004000||p +newRV||| +newSLICEOP||| +newSTATEOP||| +newSUB||| +newSVOP||| +newSVREF||| +newSV_type|5.009005||p +newSVhek||5.009003| +newSViv||| +newSVnv||| +newSVpvf_nocontext|||vn +newSVpvf||5.004000|v +newSVpvn_flags|5.011000||p +newSVpvn_share|5.007001||p +newSVpvn_utf8|5.011000||p +newSVpvn|5.004050||p +newSVpvs_flags|5.011000||p +newSVpvs_share||5.009003| +newSVpvs|5.009003||p +newSVpv||| +newSVrv||| +newSVsv||| +newSVuv|5.006000||p +newSV||| +newTOKEN||| +newUNOP||| +newWHENOP||5.009003| +newWHILEOP||5.009003| +newXS_flags||5.009004| +newXSproto||5.006000| +newXS||5.006000| +new_collate||5.006000| +new_constant||| +new_ctype||5.006000| +new_he||| +new_logop||| +new_numeric||5.006000| +new_stackinfo||5.005000| +new_version||5.009000| +new_warnings_bitfield||| +next_symbol||| +nextargv||| +nextchar||| +ninstr||| +no_bareword_allowed||| +no_fh_allowed||| +no_op||| +not_a_number||| +nothreadhook||5.008000| +nuke_stacks||| +num_overflow|||n +offer_nice_chunk||| +oopsAV||| +oopsHV||| +op_clear||| +op_const_sv||| +op_dump||5.006000| +op_free||| +op_getmad_weak||| +op_getmad||| +op_null||5.007002| +op_refcnt_dec||| +op_refcnt_inc||| +op_refcnt_lock||5.009002| +op_refcnt_unlock||5.009002| +op_xmldump||| +open_script||| +pMY_CXT_|5.007003||p +pMY_CXT|5.007003||p +pTHX_|5.006000||p +pTHX|5.006000||p +packWARN|5.007003||p +pack_cat||5.007003| +pack_rec||| +package||| +packlist||5.008001| +pad_add_anon||| +pad_add_name||| +pad_alloc||| +pad_block_start||| +pad_check_dup||| +pad_compname_type||| +pad_findlex||| +pad_findmy||| +pad_fixup_inner_anons||| +pad_free||| +pad_leavemy||| +pad_new||| +pad_peg|||n +pad_push||| +pad_reset||| +pad_setsv||| +pad_sv||5.011000| +pad_swipe||| +pad_tidy||| +pad_undef||| +parse_body||| +parse_unicode_opts||| +parser_dup||| +parser_free||| +path_is_absolute|||n +peep||| +pending_Slabs_to_ro||| +perl_alloc_using|||n +perl_alloc|||n +perl_clone_using|||n +perl_clone|||n +perl_construct|||n +perl_destruct||5.007003|n +perl_free|||n +perl_parse||5.006000|n +perl_run|||n +pidgone||| +pm_description||| +pmflag||| +pmop_dump||5.006000| +pmop_xmldump||| +pmruntime||| +pmtrans||| +pop_scope||| +pregcomp||5.009005| +pregexec||| +pregfree2||5.011000| +pregfree||| +prepend_elem||| +prepend_madprops||| +printbuf||| +printf_nocontext|||vn +process_special_blocks||| +ptr_table_clear||5.009005| +ptr_table_fetch||5.009005| +ptr_table_find|||n +ptr_table_free||5.009005| +ptr_table_new||5.009005| +ptr_table_split||5.009005| +ptr_table_store||5.009005| +push_scope||| +put_byte||| +pv_display|5.006000||p +pv_escape|5.009004||p +pv_pretty|5.009004||p +pv_uni_display||5.007003| +qerror||| +qsortsvu||| +re_compile||5.009005| +re_croak2||| +re_dup_guts||| +re_intuit_start||5.009005| +re_intuit_string||5.006000| +readpipe_override||| +realloc||5.007002|n +reentrant_free||| +reentrant_init||| +reentrant_retry|||vn +reentrant_size||| +ref_array_or_hash||| +refcounted_he_chain_2hv||| +refcounted_he_fetch||| +refcounted_he_free||| +refcounted_he_new_common||| +refcounted_he_new||| +refcounted_he_value||| +refkids||| +refto||| +ref||5.011000| +reg_check_named_buff_matched||| +reg_named_buff_all||5.009005| +reg_named_buff_exists||5.009005| +reg_named_buff_fetch||5.009005| +reg_named_buff_firstkey||5.009005| +reg_named_buff_iter||| +reg_named_buff_nextkey||5.009005| +reg_named_buff_scalar||5.009005| +reg_named_buff||| +reg_namedseq||| +reg_node||| +reg_numbered_buff_fetch||| +reg_numbered_buff_length||| +reg_numbered_buff_store||| +reg_qr_package||| +reg_recode||| +reg_scan_name||| +reg_skipcomment||| +reg_temp_copy||| +reganode||| +regatom||| +regbranch||| +regclass_swash||5.009004| +regclass||| +regcppop||| +regcppush||| +regcurly|||n +regdump_extflags||| +regdump||5.005000| +regdupe_internal||| +regexec_flags||5.005000| +regfree_internal||5.009005| +reghop3|||n +reghop4|||n +reghopmaybe3|||n +reginclass||| +reginitcolors||5.006000| +reginsert||| +regmatch||| +regnext||5.005000| +regpiece||| +regpposixcc||| +regprop||| +regrepeat||| +regtail_study||| +regtail||| +regtry||| +reguni||| +regwhite|||n +reg||| +repeatcpy||| +report_evil_fh||| +report_uninit||| +require_pv||5.006000| +require_tie_mod||| +restore_magic||| +rninstr||| +rsignal_restore||| +rsignal_save||| +rsignal_state||5.004000| +rsignal||5.004000| +run_body||| +run_user_filter||| +runops_debug||5.005000| +runops_standard||5.005000| +rvpv_dup||| +rxres_free||| +rxres_restore||| +rxres_save||| +safesyscalloc||5.006000|n +safesysfree||5.006000|n +safesysmalloc||5.006000|n +safesysrealloc||5.006000|n +same_dirent||| +save_I16||5.004000| +save_I32||| +save_I8||5.006000| +save_adelete||5.011000| +save_aelem||5.004050| +save_alloc||5.006000| +save_aptr||| +save_ary||| +save_bool||5.008001| +save_clearsv||| +save_delete||| +save_destructor_x||5.006000| +save_destructor||5.006000| +save_freeop||| +save_freepv||| +save_freesv||| +save_generic_pvref||5.006001| +save_generic_svref||5.005030| +save_gp||5.004000| +save_hash||| +save_hek_flags|||n +save_helem_flags||5.011000| +save_helem||5.004050| +save_hints||| +save_hptr||| +save_int||| +save_item||| +save_iv||5.005000| +save_lines||| +save_list||| +save_long||| +save_magic||| +save_mortalizesv||5.007001| +save_nogv||| +save_op||| +save_padsv_and_mortalize||5.011000| +save_pptr||| +save_pushi32ptr||| +save_pushptri32ptr||| +save_pushptrptr||| +save_pushptr||5.011000| +save_re_context||5.006000| +save_scalar_at||| +save_scalar||| +save_set_svflags||5.009000| +save_shared_pvref||5.007003| +save_sptr||| +save_svref||| +save_vptr||5.006000| +savepvn||| +savepvs||5.009003| +savepv||| +savesharedpvn||5.009005| +savesharedpv||5.007003| +savestack_grow_cnt||5.008001| +savestack_grow||| +savesvpv||5.009002| +sawparens||| +scalar_mod_type|||n +scalarboolean||| +scalarkids||| +scalarseq||| +scalarvoid||| +scalar||| +scan_bin||5.006000| +scan_commit||| +scan_const||| +scan_formline||| +scan_heredoc||| +scan_hex||| +scan_ident||| +scan_inputsymbol||| +scan_num||5.007001| +scan_oct||| +scan_pat||| +scan_str||| +scan_subst||| +scan_trans||| +scan_version||5.009001| +scan_vstring||5.009005| +scan_word||| +scope||| +screaminstr||5.005000| +search_const||| +seed||5.008001| +sequence_num||| +sequence_tail||| +sequence||| +set_context||5.006000|n +set_numeric_local||5.006000| +set_numeric_radix||5.006000| +set_numeric_standard||5.006000| +setdefout||| +share_hek_flags||| +share_hek||5.004000| +si_dup||| +sighandler|||n +simplify_sort||| +skipspace0||| +skipspace1||| +skipspace2||| +skipspace||| +softref2xv||| +sortcv_stacked||| +sortcv_xsub||| +sortcv||| +sortsv_flags||5.009003| +sortsv||5.007003| +space_join_names_mortal||| +ss_dup||| +stack_grow||| +start_force||| +start_glob||| +start_subparse||5.004000| +stashpv_hvname_match||5.011000| +stdize_locale||| +store_cop_label||| +strEQ||| +strGE||| +strGT||| +strLE||| +strLT||| +strNE||| +str_to_version||5.006000| +strip_return||| +strnEQ||| +strnNE||| +study_chunk||| +sub_crush_depth||| +sublex_done||| +sublex_push||| +sublex_start||| +sv_2bool||| +sv_2cv||| +sv_2io||| +sv_2iuv_common||| +sv_2iuv_non_preserve||| +sv_2iv_flags||5.009001| +sv_2iv||| +sv_2mortal||| +sv_2num||| +sv_2nv||| +sv_2pv_flags|5.007002||p +sv_2pv_nolen|5.006000||p +sv_2pvbyte_nolen|5.006000||p +sv_2pvbyte|5.006000||p +sv_2pvutf8_nolen||5.006000| +sv_2pvutf8||5.006000| +sv_2pv||| +sv_2uv_flags||5.009001| +sv_2uv|5.004000||p +sv_add_arena||| +sv_add_backref||| +sv_backoff||| +sv_bless||| +sv_cat_decode||5.008001| +sv_catpv_mg|5.004050||p +sv_catpvf_mg_nocontext|||pvn +sv_catpvf_mg|5.006000|5.004000|pv +sv_catpvf_nocontext|||vn +sv_catpvf||5.004000|v +sv_catpvn_flags||5.007002| +sv_catpvn_mg|5.004050||p +sv_catpvn_nomg|5.007002||p +sv_catpvn||| +sv_catpvs|5.009003||p +sv_catpv||| +sv_catsv_flags||5.007002| +sv_catsv_mg|5.004050||p +sv_catsv_nomg|5.007002||p +sv_catsv||| +sv_catxmlpvn||| +sv_catxmlsv||| +sv_chop||| +sv_clean_all||| +sv_clean_objs||| +sv_clear||| +sv_cmp_locale||5.004000| +sv_cmp||| +sv_collxfrm||| +sv_compile_2op||5.008001| +sv_copypv||5.007003| +sv_dec||| +sv_del_backref||| +sv_derived_from||5.004000| +sv_destroyable||5.010000| +sv_does||5.009004| +sv_dump||| +sv_dup_inc_multiple||| +sv_dup||| +sv_eq||| +sv_exp_grow||| +sv_force_normal_flags||5.007001| +sv_force_normal||5.006000| +sv_free2||| +sv_free_arenas||| +sv_free||| +sv_gets||5.004000| +sv_grow||| +sv_i_ncmp||| +sv_inc||| +sv_insert_flags||5.011000| +sv_insert||| +sv_isa||| +sv_isobject||| +sv_iv||5.005000| +sv_kill_backrefs||| +sv_len_utf8||5.006000| +sv_len||| +sv_magic_portable|5.011000|5.004000|p +sv_magicext||5.007003| +sv_magic||| +sv_mortalcopy||| +sv_ncmp||| +sv_newmortal||| +sv_newref||| +sv_nolocking||5.007003| +sv_nosharing||5.007003| +sv_nounlocking||| +sv_nv||5.005000| +sv_peek||5.005000| +sv_pos_b2u_midway||| +sv_pos_b2u||5.006000| +sv_pos_u2b_cached||| +sv_pos_u2b_forwards|||n +sv_pos_u2b_midway|||n +sv_pos_u2b||5.006000| +sv_pvbyten_force||5.006000| +sv_pvbyten||5.006000| +sv_pvbyte||5.006000| +sv_pvn_force_flags|5.007002||p +sv_pvn_force||| +sv_pvn_nomg|5.007003|5.005000|p +sv_pvn||5.005000| +sv_pvutf8n_force||5.006000| +sv_pvutf8n||5.006000| +sv_pvutf8||5.006000| +sv_pv||5.006000| +sv_recode_to_utf8||5.007003| +sv_reftype||| +sv_release_COW||| +sv_replace||| +sv_report_used||| +sv_reset||| +sv_rvweaken||5.006000| +sv_setiv_mg|5.004050||p +sv_setiv||| +sv_setnv_mg|5.006000||p +sv_setnv||| +sv_setpv_mg|5.004050||p +sv_setpvf_mg_nocontext|||pvn +sv_setpvf_mg|5.006000|5.004000|pv +sv_setpvf_nocontext|||vn +sv_setpvf||5.004000|v +sv_setpviv_mg||5.008001| +sv_setpviv||5.008001| +sv_setpvn_mg|5.004050||p +sv_setpvn||| +sv_setpvs|5.009004||p +sv_setpv||| +sv_setref_iv||| +sv_setref_nv||| +sv_setref_pvn||| +sv_setref_pv||| +sv_setref_uv||5.007001| +sv_setsv_cow||| +sv_setsv_flags||5.007002| +sv_setsv_mg|5.004050||p +sv_setsv_nomg|5.007002||p +sv_setsv||| +sv_setuv_mg|5.004050||p +sv_setuv|5.004000||p +sv_tainted||5.004000| +sv_taint||5.004000| +sv_true||5.005000| +sv_unglob||| +sv_uni_display||5.007003| +sv_unmagic||| +sv_unref_flags||5.007001| +sv_unref||| +sv_untaint||5.004000| +sv_upgrade||| +sv_usepvn_flags||5.009004| +sv_usepvn_mg|5.004050||p +sv_usepvn||| +sv_utf8_decode||5.006000| +sv_utf8_downgrade||5.006000| +sv_utf8_encode||5.006000| +sv_utf8_upgrade_flags_grow||5.011000| +sv_utf8_upgrade_flags||5.007002| +sv_utf8_upgrade_nomg||5.007002| +sv_utf8_upgrade||5.007001| +sv_uv|5.005000||p +sv_vcatpvf_mg|5.006000|5.004000|p +sv_vcatpvfn||5.004000| +sv_vcatpvf|5.006000|5.004000|p +sv_vsetpvf_mg|5.006000|5.004000|p +sv_vsetpvfn||5.004000| +sv_vsetpvf|5.006000|5.004000|p +sv_xmlpeek||| +svtype||| +swallow_bom||| +swap_match_buff||| +swash_fetch||5.007002| +swash_get||| +swash_init||5.006000| +sys_init3||5.010000|n +sys_init||5.010000|n +sys_intern_clear||| +sys_intern_dup||| +sys_intern_init||| +sys_term||5.010000|n +taint_env||| +taint_proper||| +tmps_grow||5.006000| +toLOWER||| +toUPPER||| +to_byte_substr||| +to_uni_fold||5.007003| +to_uni_lower_lc||5.006000| +to_uni_lower||5.007003| +to_uni_title_lc||5.006000| +to_uni_title||5.007003| +to_uni_upper_lc||5.006000| +to_uni_upper||5.007003| +to_utf8_case||5.007003| +to_utf8_fold||5.007003| +to_utf8_lower||5.007003| +to_utf8_substr||| +to_utf8_title||5.007003| +to_utf8_upper||5.007003| +token_free||| +token_getmad||| +tokenize_use||| +tokeq||| +tokereport||| +too_few_arguments||| +too_many_arguments||| +uiv_2buf|||n +unlnk||| +unpack_rec||| +unpack_str||5.007003| +unpackstring||5.008001| +unshare_hek_or_pvn||| +unshare_hek||| +unsharepvn||5.004000| +unwind_handler_stack||| +update_debugger_info||| +upg_version||5.009005| +usage||| +utf16_to_utf8_reversed||5.006001| +utf16_to_utf8||5.006001| +utf8_distance||5.006000| +utf8_hop||5.006000| +utf8_length||5.007001| +utf8_mg_pos_cache_update||| +utf8_to_bytes||5.006001| +utf8_to_uvchr||5.007001| +utf8_to_uvuni||5.007001| +utf8n_to_uvchr||| +utf8n_to_uvuni||5.007001| +utilize||| +uvchr_to_utf8_flags||5.007003| +uvchr_to_utf8||| +uvuni_to_utf8_flags||5.007003| +uvuni_to_utf8||5.007001| +validate_suid||| +varname||| +vcmp||5.009000| +vcroak||5.006000| +vdeb||5.007003| +vdie_common||| +vdie_croak_common||| +vdie||| +vform||5.006000| +visit||| +vivify_defelem||| +vivify_ref||| +vload_module|5.006000||p +vmess||5.006000| +vnewSVpvf|5.006000|5.004000|p +vnormal||5.009002| +vnumify||5.009000| +vstringify||5.009000| +vverify||5.009003| +vwarner||5.006000| +vwarn||5.006000| +wait4pid||| +warn_nocontext|||vn +warner_nocontext|||vn +warner|5.006000|5.004000|pv +warn|||v +watch||| +whichsig||| +write_no_mem||| +write_to_stderr||| +xmldump_all||| +xmldump_attr||| +xmldump_eval||| +xmldump_form||| +xmldump_indent|||v +xmldump_packsubs||| +xmldump_sub||| +xmldump_vindent||| +yyerror||| +yylex||| +yyparse||| +yywarn||| +); + +if (exists $opt{'list-unsupported'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{todo}; + print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; + } + exit 0; +} + +# Scan for possible replacement candidates + +my(%replace, %need, %hints, %warnings, %depends); +my $replace = 0; +my($hint, $define, $function); + +sub find_api +{ + my $code = shift; + $code =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; + grep { exists $API{$_} } $code =~ /(\w+)/mg; +} + +while (<DATA>) { + if ($hint) { + my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; + if (m{^\s*\*\s(.*?)\s*$}) { + for (@{$hint->[1]}) { + $h->{$_} ||= ''; # suppress warning with older perls + $h->{$_} .= "$1\n"; + } + } + else { undef $hint } + } + + $hint = [$1, [split /,?\s+/, $2]] + if m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}; + + if ($define) { + if ($define->[1] =~ /\\$/) { + $define->[1] .= $_; + } + else { + if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { + my @n = find_api($define->[1]); + push @{$depends{$define->[0]}}, @n if @n + } + undef $define; + } + } + + $define = [$1, $2] if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(.*)}; + + if ($function) { + if (/^}/) { + if (exists $API{$function->[0]}) { + my @n = find_api($function->[1]); + push @{$depends{$function->[0]}}, @n if @n + } + undef $function; + } + else { + $function->[1] .= $_; + } + } + + $function = [$1, ''] if m{^DPPP_\(my_(\w+)\)}; + + $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; + $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; + $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; + $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; + + if (m{^\s*$rccs\s+(\w+(\s*,\s*\w+)*)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) { + my @deps = map { s/\s+//g; $_ } split /,/, $3; + my $d; + for $d (map { s/\s+//g; $_ } split /,/, $1) { + push @{$depends{$d}}, @deps; + } + } + + $need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)}; +} + +for (values %depends) { + my %s; + $_ = [sort grep !$s{$_}++, @$_]; +} + +if (exists $opt{'api-info'}) { + my $f; + my $count = 0; + my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$"; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $f =~ /$match/; + print "\n=== $f ===\n\n"; + my $info = 0; + if ($API{$f}{base} || $API{$f}{todo}) { + my $base = format_version($API{$f}{base} || $API{$f}{todo}); + print "Supported at least starting from perl-$base.\n"; + $info++; + } + if ($API{$f}{provided}) { + my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "5.003"; + print "Support by $ppport provided back to perl-$todo.\n"; + print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f}; + print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; + print "\n$hints{$f}" if exists $hints{$f}; + print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; + $info++; + } + print "No portability information available.\n" unless $info; + $count++; + } + $count or print "Found no API matching '$opt{'api-info'}'."; + print "\n"; + exit 0; +} + +if (exists $opt{'list-provided'}) { + my $f; + for $f (sort { lc $a cmp lc $b } keys %API) { + next unless $API{$f}{provided}; + my @flags; + push @flags, 'explicit' if exists $need{$f}; + push @flags, 'depend' if exists $depends{$f}; + push @flags, 'hint' if exists $hints{$f}; + push @flags, 'warning' if exists $warnings{$f}; + my $flags = @flags ? ' ['.join(', ', @flags).']' : ''; + print "$f$flags\n"; + } + exit 0; +} + +my @files; +my @srcext = qw( .xs .c .h .cc .cpp -c.inc -xs.inc ); +my $srcext = join '|', map { quotemeta $_ } @srcext; + +if (@ARGV) { + my %seen; + for (@ARGV) { + if (-e) { + if (-f) { + push @files, $_ unless $seen{$_}++; + } + else { warn "'$_' is not a file.\n" } + } + else { + my @new = grep { -f } glob $_ + or warn "'$_' does not exist.\n"; + push @files, grep { !$seen{$_}++ } @new; + } + } +} +else { + eval { + require File::Find; + File::Find::find(sub { + $File::Find::name =~ /($srcext)$/i + and push @files, $File::Find::name; + }, '.'); + }; + if ($@) { + @files = map { glob "*$_" } @srcext; + } +} + +if (!@ARGV || $opt{filter}) { + my(@in, @out); + my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files; + for (@files) { + my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/($srcext)$/i; + push @{ $out ? \@out : \@in }, $_; + } + if (@ARGV && @out) { + warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out); + } + @files = @in; +} + +die "No input files given!\n" unless @files; + +my(%files, %global, %revreplace); +%revreplace = reverse %replace; +my $filename; +my $patch_opened = 0; + +for $filename (@files) { + unless (open IN, "<$filename") { + warn "Unable to read from $filename: $!\n"; + next; + } + + info("Scanning $filename ..."); + + my $c = do { local $/; <IN> }; + close IN; + + my %file = (orig => $c, changes => 0); + + # Temporarily remove C/XS comments and strings from the code + my @ccom; + + $c =~ s{ + ( ^$HS*\#$HS*include\b[^\r\n]+\b(?:\Q$ppport\E|XSUB\.h)\b[^\r\n]* + | ^$HS*\#$HS*(?:define|elif|if(?:def)?)\b[^\r\n]* ) + | ( ^$HS*\#[^\r\n]* + | "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' + | / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]* ) ) + }{ defined $2 and push @ccom, $2; + defined $1 ? $1 : "$ccs$#ccom$cce" }mgsex; + + $file{ccom} = \@ccom; + $file{code} = $c; + $file{has_inc_ppport} = $c =~ /^$HS*#$HS*include[^\r\n]+\b\Q$ppport\E\b/m; + + my $func; + + for $func (keys %API) { + my $match = $func; + $match .= "|$revreplace{$func}" if exists $revreplace{$func}; + if ($c =~ /\b(?:Perl_)?($match)\b/) { + $file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func}; + $file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/; + if (exists $API{$func}{provided}) { + $file{uses_provided}{$func}++; + if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) { + $file{uses}{$func}++; + my @deps = rec_depend($func); + if (@deps) { + $file{uses_deps}{$func} = \@deps; + for (@deps) { + $file{uses}{$_} = 0 unless exists $file{uses}{$_}; + } + } + for ($func, @deps) { + $file{needs}{$_} = 'static' if exists $need{$_}; + } + } + } + if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) { + if ($c =~ /\b$func\b/) { + $file{uses_todo}{$func}++; + } + } + } + } + + while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) { + if (exists $need{$2}) { + $file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++; + } + else { warning("Possibly wrong #define $1 in $filename") } + } + + for (qw(uses needs uses_todo needed_global needed_static)) { + for $func (keys %{$file{$_}}) { + push @{$global{$_}{$func}}, $filename; + } + } + + $files{$filename} = \%file; +} + +# Globally resolve NEED_'s +my $need; +for $need (keys %{$global{needs}}) { + if (@{$global{needs}{$need}} > 1) { + my @targets = @{$global{needs}{$need}}; + my @t = grep $files{$_}{needed_global}{$need}, @targets; + @targets = @t if @t; + @t = grep /\.xs$/i, @targets; + @targets = @t if @t; + my $target = shift @targets; + $files{$target}{needs}{$need} = 'global'; + for (@{$global{needs}{$need}}) { + $files{$_}{needs}{$need} = 'extern' if $_ ne $target; + } + } +} + +for $filename (@files) { + exists $files{$filename} or next; + + info("=== Analyzing $filename ==="); + + my %file = %{$files{$filename}}; + my $func; + my $c = $file{code}; + my $warnings = 0; + + for $func (sort keys %{$file{uses_Perl}}) { + if ($API{$func}{varargs}) { + unless ($API{$func}{nothxarg}) { + my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))} + { $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge); + if ($changes) { + warning("Doesn't pass interpreter argument aTHX to Perl_$func"); + $file{changes} += $changes; + } + } + } + else { + warning("Uses Perl_$func instead of $func"); + $file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*} + {$func$1(}g); + } + } + + for $func (sort keys %{$file{uses_replace}}) { + warning("Uses $func instead of $replace{$func}"); + $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); + } + + for $func (sort keys %{$file{uses_provided}}) { + if ($file{uses}{$func}) { + if (exists $file{uses_deps}{$func}) { + diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}})); + } + else { + diag("Uses $func"); + } + } + $warnings += hint($func); + } + + unless ($opt{quiet}) { + for $func (sort keys %{$file{uses_todo}}) { + print "*** WARNING: Uses $func, which may not be portable below perl ", + format_version($API{$func}{todo}), ", even with '$ppport'\n"; + $warnings++; + } + } + + for $func (sort keys %{$file{needed_static}}) { + my $message = ''; + if (not exists $file{uses}{$func}) { + $message = "No need to define NEED_$func if $func is never used"; + } + elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') { + $message = "No need to define NEED_$func when already needed globally"; + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg); + } + } + + for $func (sort keys %{$file{needed_global}}) { + my $message = ''; + if (not exists $global{uses}{$func}) { + $message = "No need to define NEED_${func}_GLOBAL if $func is never used"; + } + elsif (exists $file{needs}{$func}) { + if ($file{needs}{$func} eq 'extern') { + $message = "No need to define NEED_${func}_GLOBAL when already needed globally"; + } + elsif ($file{needs}{$func} eq 'static') { + $message = "No need to define NEED_${func}_GLOBAL when only used in this file"; + } + } + if ($message) { + diag($message); + $file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg); + } + } + + $file{needs_inc_ppport} = keys %{$file{uses}}; + + if ($file{needs_inc_ppport}) { + my $pp = ''; + + for $func (sort keys %{$file{needs}}) { + my $type = $file{needs}{$func}; + next if $type eq 'extern'; + my $suffix = $type eq 'global' ? '_GLOBAL' : ''; + unless (exists $file{"needed_$type"}{$func}) { + if ($type eq 'global') { + diag("Files [@{$global{needs}{$func}}] need $func, adding global request"); + } + else { + diag("File needs $func, adding static request"); + } + $pp .= "#define NEED_$func$suffix\n"; + } + } + + if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) { + $pp = ''; + $file{changes}++; + } + + unless ($file{has_inc_ppport}) { + diag("Needs to include '$ppport'"); + $pp .= qq(#include "$ppport"\n) + } + + if ($pp) { + $file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms) + || ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m) + || ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m) + || ($c =~ s/^/$pp/); + } + } + else { + if ($file{has_inc_ppport}) { + diag("No need to include '$ppport'"); + $file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m); + } + } + + # put back in our C comments + my $ix; + my $cppc = 0; + my @ccom = @{$file{ccom}}; + for $ix (0 .. $#ccom) { + if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) { + $cppc++; + $file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/; + } + else { + $c =~ s/$rccs$ix$rcce/$ccom[$ix]/; + } + } + + if ($cppc) { + my $s = $cppc != 1 ? 's' : ''; + warning("Uses $cppc C++ style comment$s, which is not portable"); + } + + my $s = $warnings != 1 ? 's' : ''; + my $warn = $warnings ? " ($warnings warning$s)" : ''; + info("Analysis completed$warn"); + + if ($file{changes}) { + if (exists $opt{copy}) { + my $newfile = "$filename$opt{copy}"; + if (-e $newfile) { + error("'$newfile' already exists, refusing to write copy of '$filename'"); + } + else { + local *F; + if (open F, ">$newfile") { + info("Writing copy of '$filename' with changes to '$newfile'"); + print F $c; + close F; + } + else { + error("Cannot open '$newfile' for writing: $!"); + } + } + } + elsif (exists $opt{patch} || $opt{changes}) { + if (exists $opt{patch}) { + unless ($patch_opened) { + if (open PATCH, ">$opt{patch}") { + $patch_opened = 1; + } + else { + error("Cannot open '$opt{patch}' for writing: $!"); + delete $opt{patch}; + $opt{changes} = 1; + goto fallback; + } + } + mydiff(\*PATCH, $filename, $c); + } + else { +fallback: + info("Suggested changes:"); + mydiff(\*STDOUT, $filename, $c); + } + } + else { + my $s = $file{changes} == 1 ? '' : 's'; + info("$file{changes} potentially required change$s detected"); + } + } + else { + info("Looks good"); + } +} + +close PATCH if $patch_opened; + +exit 0; + + +sub try_use { eval "use @_;"; return $@ eq '' } + +sub mydiff +{ + local *F = shift; + my($file, $str) = @_; + my $diff; + + if (exists $opt{diff}) { + $diff = run_diff($opt{diff}, $file, $str); + } + + if (!defined $diff and try_use('Text::Diff')) { + $diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' }); + $diff = <<HEADER . $diff; +--- $file ++++ $file.patched +HEADER + } + + if (!defined $diff) { + $diff = run_diff('diff -u', $file, $str); + } + + if (!defined $diff) { + $diff = run_diff('diff', $file, $str); + } + + if (!defined $diff) { + error("Cannot generate a diff. Please install Text::Diff or use --copy."); + return; + } + + print F $diff; +} + +sub run_diff +{ + my($prog, $file, $str) = @_; + my $tmp = 'dppptemp'; + my $suf = 'aaa'; + my $diff = ''; + local *F; + + while (-e "$tmp.$suf") { $suf++ } + $tmp = "$tmp.$suf"; + + if (open F, ">$tmp") { + print F $str; + close F; + + if (open F, "$prog $file $tmp |") { + while (<F>) { + s/\Q$tmp\E/$file.patched/; + $diff .= $_; + } + close F; + unlink $tmp; + return $diff; + } + + unlink $tmp; + } + else { + error("Cannot open '$tmp' for writing: $!"); + } + + return undef; +} + +sub rec_depend +{ + my($func, $seen) = @_; + return () unless exists $depends{$func}; + $seen = {%{$seen||{}}}; + return () if $seen->{$func}++; + my %s; + grep !$s{$_}++, map { ($_, rec_depend($_, $seen)) } @{$depends{$func}}; +} + +sub parse_version +{ + my $ver = shift; + + if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) { + return ($1, $2, $3); + } + elsif ($ver !~ /^\d+\.[\d_]+$/) { + die "cannot parse version '$ver'\n"; + } + + $ver =~ s/_//g; + $ver =~ s/$/000000/; + + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "cannot parse version '$ver'\n"; + } + } + + return ($r, $v, $s); +} + +sub format_version +{ + my $ver = shift; + + $ver =~ s/$/000000/; + my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/; + + $v = int $v; + $s = int $s; + + if ($r < 5 || ($r == 5 && $v < 6)) { + if ($s % 10) { + die "invalid version '$ver'\n"; + } + $s /= 10; + + $ver = sprintf "%d.%03d", $r, $v; + $s > 0 and $ver .= sprintf "_%02d", $s; + + return $ver; + } + + return sprintf "%d.%d.%d", $r, $v, $s; +} + +sub info +{ + $opt{quiet} and return; + print @_, "\n"; +} + +sub diag +{ + $opt{quiet} and return; + $opt{diag} and print @_, "\n"; +} + +sub warning +{ + $opt{quiet} and return; + print "*** ", @_, "\n"; +} + +sub error +{ + print "*** ERROR: ", @_, "\n"; +} + +my %given_hints; +my %given_warnings; +sub hint +{ + $opt{quiet} and return; + my $func = shift; + my $rv = 0; + if (exists $warnings{$func} && !$given_warnings{$func}++) { + my $warn = $warnings{$func}; + $warn =~ s!^!*** !mg; + print "*** WARNING: $func\n", $warn; + $rv++; + } + if ($opt{hints} && exists $hints{$func} && !$given_hints{$func}++) { + my $hint = $hints{$func}; + $hint =~ s/^/ /mg; + print " --- hint for $func ---\n", $hint; + } + $rv; +} + +sub usage +{ + my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms; + my %M = ( 'I' => '*' ); + $usage =~ s/^\s*perl\s+\S+/$^X $0/; + $usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g; + + print <<ENDUSAGE; + +Usage: $usage + +See perldoc $0 for details. + +ENDUSAGE + + exit 2; +} + +sub strip +{ + my $self = do { local(@ARGV,$/)=($0); <> }; + my($copy) = $self =~ /^=head\d\s+COPYRIGHT\s*^(.*?)^=\w+/ms; + $copy =~ s/^(?=\S+)/ /gms; + $self =~ s/^$HS+Do NOT edit.*?(?=^-)/$copy/ms; + $self =~ s/^SKIP.*(?=^__DATA__)/SKIP +if (\@ARGV && \$ARGV[0] eq '--unstrip') { + eval { require Devel::PPPort }; + \$@ and die "Cannot require Devel::PPPort, please install.\\n"; + if (eval \$Devel::PPPort::VERSION < $VERSION) { + die "$0 was originally generated with Devel::PPPort $VERSION.\\n" + . "Your Devel::PPPort is only version \$Devel::PPPort::VERSION.\\n" + . "Please install a newer version, or --unstrip will not work.\\n"; + } + Devel::PPPort::WriteFile(\$0); + exit 0; +} +print <<END; + +Sorry, but this is a stripped version of \$0. + +To be able to use its original script and doc functionality, +please try to regenerate this file using: + + \$^X \$0 --unstrip + +END +/ms; + my($pl, $c) = $self =~ /(.*^__DATA__)(.*)/ms; + $c =~ s{ + / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) + | ( "[^"\\]*(?:\\.[^"\\]*)*" + | '[^'\\]*(?:\\.[^'\\]*)*' ) + | ($HS+) }{ defined $2 ? ' ' : ($1 || '') }gsex; + $c =~ s!\s+$!!mg; + $c =~ s!^$LF!!mg; + $c =~ s!^\s*#\s*!#!mg; + $c =~ s!^\s+!!mg; + + open OUT, ">$0" or die "cannot strip $0: $!\n"; + print OUT "$pl$c\n"; + + exit 0; +} + +__DATA__ +*/ + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +#ifndef DPPP_NAMESPACE +# define DPPP_NAMESPACE DPPP_ +#endif + +#define DPPP_CAT2(x,y) CAT2(x,y) +#define DPPP_(name) DPPP_CAT2(DPPP_NAMESPACE, name) + +#ifndef PERL_REVISION +# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION)) +# define PERL_PATCHLEVEL_H_IMPLICIT +# include <patchlevel.h> +# endif +# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL))) +# include <could_not_find_Perl_patchlevel.h> +# endif +# ifndef PERL_REVISION +# define PERL_REVISION (5) + /* Replace: 1 */ +# define PERL_VERSION PATCHLEVEL +# define PERL_SUBVERSION SUBVERSION + /* Replace PERL_PATCHLEVEL with PERL_VERSION */ + /* Replace: 0 */ +# endif +#endif + +#define _dpppDEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) +#define PERL_BCDVERSION ((_dpppDEC2BCD(PERL_REVISION)<<24)|(_dpppDEC2BCD(PERL_VERSION)<<12)|_dpppDEC2BCD(PERL_SUBVERSION)) + +/* It is very unlikely that anyone will try to use this with Perl 6 + (or greater), but who knows. + */ +#if PERL_REVISION != 5 +# error ppport.h only works with Perl version 5 +#endif /* PERL_REVISION != 5 */ +#ifndef dTHR +# define dTHR dNOOP +#endif +#ifndef dTHX +# define dTHX dNOOP +#endif + +#ifndef dTHXa +# define dTHXa(x) dNOOP +#endif +#ifndef pTHX +# define pTHX void +#endif + +#ifndef pTHX_ +# define pTHX_ +#endif + +#ifndef aTHX +# define aTHX +#endif + +#ifndef aTHX_ +# define aTHX_ +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# ifdef USE_THREADS +# define aTHXR thr +# define aTHXR_ thr, +# else +# define aTHXR +# define aTHXR_ +# endif +# define dTHXR dTHR +#else +# define aTHXR aTHX +# define aTHXR_ aTHX_ +# define dTHXR dTHX +#endif +#ifndef dTHXoa +# define dTHXoa(x) dTHXa(x) +#endif + +#ifdef I_LIMITS +# include <limits.h> +#endif + +#ifndef PERL_UCHAR_MIN +# define PERL_UCHAR_MIN ((unsigned char)0) +#endif + +#ifndef PERL_UCHAR_MAX +# ifdef UCHAR_MAX +# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX) +# else +# ifdef MAXUCHAR +# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR) +# else +# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0) +# endif +# endif +#endif + +#ifndef PERL_USHORT_MIN +# define PERL_USHORT_MIN ((unsigned short)0) +#endif + +#ifndef PERL_USHORT_MAX +# ifdef USHORT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX) +# else +# ifdef MAXUSHORT +# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT) +# else +# ifdef USHRT_MAX +# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX) +# else +# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MAX +# ifdef SHORT_MAX +# define PERL_SHORT_MAX ((short)SHORT_MAX) +# else +# ifdef MAXSHORT /* Often used in <values.h> */ +# define PERL_SHORT_MAX ((short)MAXSHORT) +# else +# ifdef SHRT_MAX +# define PERL_SHORT_MAX ((short)SHRT_MAX) +# else +# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1)) +# endif +# endif +# endif +#endif + +#ifndef PERL_SHORT_MIN +# ifdef SHORT_MIN +# define PERL_SHORT_MIN ((short)SHORT_MIN) +# else +# ifdef MINSHORT +# define PERL_SHORT_MIN ((short)MINSHORT) +# else +# ifdef SHRT_MIN +# define PERL_SHORT_MIN ((short)SHRT_MIN) +# else +# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +#ifndef PERL_UINT_MAX +# ifdef UINT_MAX +# define PERL_UINT_MAX ((unsigned int)UINT_MAX) +# else +# ifdef MAXUINT +# define PERL_UINT_MAX ((unsigned int)MAXUINT) +# else +# define PERL_UINT_MAX (~(unsigned int)0) +# endif +# endif +#endif + +#ifndef PERL_UINT_MIN +# define PERL_UINT_MIN ((unsigned int)0) +#endif + +#ifndef PERL_INT_MAX +# ifdef INT_MAX +# define PERL_INT_MAX ((int)INT_MAX) +# else +# ifdef MAXINT /* Often used in <values.h> */ +# define PERL_INT_MAX ((int)MAXINT) +# else +# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_INT_MIN +# ifdef INT_MIN +# define PERL_INT_MIN ((int)INT_MIN) +# else +# ifdef MININT +# define PERL_INT_MIN ((int)MININT) +# else +# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MAX +# ifdef ULONG_MAX +# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX) +# else +# ifdef MAXULONG +# define PERL_ULONG_MAX ((unsigned long)MAXULONG) +# else +# define PERL_ULONG_MAX (~(unsigned long)0) +# endif +# endif +#endif + +#ifndef PERL_ULONG_MIN +# define PERL_ULONG_MIN ((unsigned long)0L) +#endif + +#ifndef PERL_LONG_MAX +# ifdef LONG_MAX +# define PERL_LONG_MAX ((long)LONG_MAX) +# else +# ifdef MAXLONG +# define PERL_LONG_MAX ((long)MAXLONG) +# else +# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1)) +# endif +# endif +#endif + +#ifndef PERL_LONG_MIN +# ifdef LONG_MIN +# define PERL_LONG_MIN ((long)LONG_MIN) +# else +# ifdef MINLONG +# define PERL_LONG_MIN ((long)MINLONG) +# else +# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3)) +# endif +# endif +#endif + +#if defined(HAS_QUAD) && (defined(convex) || defined(uts)) +# ifndef PERL_UQUAD_MAX +# ifdef ULONGLONG_MAX +# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX) +# else +# ifdef MAXULONGLONG +# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG) +# else +# define PERL_UQUAD_MAX (~(unsigned long long)0) +# endif +# endif +# endif + +# ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN ((unsigned long long)0L) +# endif + +# ifndef PERL_QUAD_MAX +# ifdef LONGLONG_MAX +# define PERL_QUAD_MAX ((long long)LONGLONG_MAX) +# else +# ifdef MAXLONGLONG +# define PERL_QUAD_MAX ((long long)MAXLONGLONG) +# else +# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1)) +# endif +# endif +# endif + +# ifndef PERL_QUAD_MIN +# ifdef LONGLONG_MIN +# define PERL_QUAD_MIN ((long long)LONGLONG_MIN) +# else +# ifdef MINLONGLONG +# define PERL_QUAD_MIN ((long long)MINLONGLONG) +# else +# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3)) +# endif +# endif +# endif +#endif + +/* This is based on code from 5.003 perl.h */ +#ifdef HAS_QUAD +# ifdef cray +#ifndef IVTYPE +# define IVTYPE int +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_INT_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_INT_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UINT_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UINT_MAX +#endif + +# ifdef INTSIZE +#ifndef IVSIZE +# define IVSIZE INTSIZE +#endif + +# endif +# else +# if defined(convex) || defined(uts) +#ifndef IVTYPE +# define IVTYPE long long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_QUAD_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_QUAD_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_UQUAD_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_UQUAD_MAX +#endif + +# ifdef LONGLONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGLONGSIZE +#endif + +# endif +# else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +# ifdef LONGSIZE +#ifndef IVSIZE +# define IVSIZE LONGSIZE +#endif + +# endif +# endif +# endif +#ifndef IVSIZE +# define IVSIZE 8 +#endif + +#ifndef PERL_QUAD_MIN +# define PERL_QUAD_MIN IV_MIN +#endif + +#ifndef PERL_QUAD_MAX +# define PERL_QUAD_MAX IV_MAX +#endif + +#ifndef PERL_UQUAD_MIN +# define PERL_UQUAD_MIN UV_MIN +#endif + +#ifndef PERL_UQUAD_MAX +# define PERL_UQUAD_MAX UV_MAX +#endif + +#else +#ifndef IVTYPE +# define IVTYPE long +#endif + +#ifndef IV_MIN +# define IV_MIN PERL_LONG_MIN +#endif + +#ifndef IV_MAX +# define IV_MAX PERL_LONG_MAX +#endif + +#ifndef UV_MIN +# define UV_MIN PERL_ULONG_MIN +#endif + +#ifndef UV_MAX +# define UV_MAX PERL_ULONG_MAX +#endif + +#endif + +#ifndef IVSIZE +# ifdef LONGSIZE +# define IVSIZE LONGSIZE +# else +# define IVSIZE 4 /* A bold guess, but the best we can make. */ +# endif +#endif +#ifndef UVTYPE +# define UVTYPE unsigned IVTYPE +#endif + +#ifndef UVSIZE +# define UVSIZE IVSIZE +#endif +#ifndef sv_setuv +# define sv_setuv(sv, uv) \ + STMT_START { \ + UV TeMpUv = uv; \ + if (TeMpUv <= IV_MAX) \ + sv_setiv(sv, TeMpUv); \ + else \ + sv_setnv(sv, (double)TeMpUv); \ + } STMT_END +#endif +#ifndef newSVuv +# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv)) +#endif +#ifndef sv_2uv +# define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) +#endif + +#ifndef SvUVX +# define SvUVX(sv) ((UV)SvIVX(sv)) +#endif + +#ifndef SvUVXx +# define SvUVXx(sv) SvUVX(sv) +#endif + +#ifndef SvUV +# define SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv)) +#endif + +#ifndef SvUVx +# define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) +#endif + +/* Hint: sv_uv + * Always use the SvUVx() macro instead of sv_uv(). + */ +#ifndef sv_uv +# define sv_uv(sv) SvUVx(sv) +#endif + +#if !defined(SvUOK) && defined(SvIOK_UV) +# define SvUOK(sv) SvIOK_UV(sv) +#endif +#ifndef XST_mUV +# define XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) ) +#endif + +#ifndef XSRETURN_UV +# define XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END +#endif +#ifndef PUSHu +# define PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END +#endif + +#ifndef XPUSHu +# define XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END +#endif + +#ifdef HAS_MEMCMP +#ifndef memNE +# define memNE(s1,s2,l) (memcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!memcmp(s1,s2,l)) +#endif + +#else +#ifndef memNE +# define memNE(s1,s2,l) (bcmp(s1,s2,l)) +#endif + +#ifndef memEQ +# define memEQ(s1,s2,l) (!bcmp(s1,s2,l)) +#endif + +#endif +#ifndef MoveD +# define MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifndef CopyD +# define CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t)) +#endif + +#ifdef HAS_MEMSET +#ifndef ZeroD +# define ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t)) +#endif + +#else +#ifndef ZeroD +# define ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)), d) +#endif + +#endif +#ifndef PoisonWith +# define PoisonWith(d,n,t,b) (void)memset((char*)(d), (U8)(b), (n) * sizeof(t)) +#endif + +#ifndef PoisonNew +# define PoisonNew(d,n,t) PoisonWith(d,n,t,0xAB) +#endif + +#ifndef PoisonFree +# define PoisonFree(d,n,t) PoisonWith(d,n,t,0xEF) +#endif + +#ifndef Poison +# define Poison(d,n,t) PoisonFree(d,n,t) +#endif +#ifndef Newx +# define Newx(v,n,t) New(0,v,n,t) +#endif + +#ifndef Newxc +# define Newxc(v,n,t,c) Newc(0,v,n,t,c) +#endif + +#ifndef Newxz +# define Newxz(v,n,t) Newz(0,v,n,t) +#endif + +#ifndef PERL_UNUSED_DECL +# ifdef HASATTRIBUTE +# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) +# define PERL_UNUSED_DECL +# else +# define PERL_UNUSED_DECL __attribute__((unused)) +# endif +# else +# define PERL_UNUSED_DECL +# endif +#endif + +#ifndef PERL_UNUSED_ARG +# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ +# include <note.h> +# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) +# else +# define PERL_UNUSED_ARG(x) ((void)x) +# endif +#endif + +#ifndef PERL_UNUSED_VAR +# define PERL_UNUSED_VAR(x) ((void)x) +#endif + +#ifndef PERL_UNUSED_CONTEXT +# ifdef USE_ITHREADS +# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) +# else +# define PERL_UNUSED_CONTEXT +# endif +#endif +#ifndef NOOP +# define NOOP /*EMPTY*/(void)0 +#endif + +#ifndef dNOOP +# define dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL +#endif + +#ifndef NVTYPE +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) +# define NVTYPE long double +# else +# define NVTYPE double +# endif +typedef NVTYPE NV; +#endif + +#ifndef INT2PTR +# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) +# define PTRV UV +# define INT2PTR(any,d) (any)(d) +# else +# if PTRSIZE == LONGSIZE +# define PTRV unsigned long +# else +# define PTRV unsigned +# endif +# define INT2PTR(any,d) (any)(PTRV)(d) +# endif +#endif + +#ifndef PTR2ul +# if PTRSIZE == LONGSIZE +# define PTR2ul(p) (unsigned long)(p) +# else +# define PTR2ul(p) INT2PTR(unsigned long,p) +# endif +#endif +#ifndef PTR2nat +# define PTR2nat(p) (PTRV)(p) +#endif + +#ifndef NUM2PTR +# define NUM2PTR(any,d) (any)PTR2nat(d) +#endif + +#ifndef PTR2IV +# define PTR2IV(p) INT2PTR(IV,p) +#endif + +#ifndef PTR2UV +# define PTR2UV(p) INT2PTR(UV,p) +#endif + +#ifndef PTR2NV +# define PTR2NV(p) NUM2PTR(NV,p) +#endif + +#undef START_EXTERN_C +#undef END_EXTERN_C +#undef EXTERN_C +#ifdef __cplusplus +# define START_EXTERN_C extern "C" { +# define END_EXTERN_C } +# define EXTERN_C extern "C" +#else +# define START_EXTERN_C +# define END_EXTERN_C +# define EXTERN_C extern +#endif + +#if defined(PERL_GCC_PEDANTIC) +# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN +# define PERL_GCC_BRACE_GROUPS_FORBIDDEN +# endif +#endif + +#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) +# ifndef PERL_USE_GCC_BRACE_GROUPS +# define PERL_USE_GCC_BRACE_GROUPS +# endif +#endif + +#undef STMT_START +#undef STMT_END +#ifdef PERL_USE_GCC_BRACE_GROUPS +# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ +# define STMT_END ) +#else +# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) +# define STMT_START if (1) +# define STMT_END else (void)0 +# else +# define STMT_START do +# define STMT_END while (0) +# endif +#endif +#ifndef boolSV +# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no) +#endif + +/* DEFSV appears first in 5.004_56 */ +#ifndef DEFSV +# define DEFSV GvSV(PL_defgv) +#endif + +#ifndef SAVE_DEFSV +# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) +#endif + +#ifndef DEFSV_set +# define DEFSV_set(sv) (DEFSV = (sv)) +#endif + +/* Older perls (<=5.003) lack AvFILLp */ +#ifndef AvFILLp +# define AvFILLp AvFILL +#endif +#ifndef ERRSV +# define ERRSV get_sv("@",FALSE) +#endif + +/* Hint: gv_stashpvn + * This function's backport doesn't support the length parameter, but + * rather ignores it. Portability can only be ensured if the length + * parameter is used for speed reasons, but the length can always be + * correctly computed from the string argument. + */ +#ifndef gv_stashpvn +# define gv_stashpvn(str,len,create) gv_stashpv(str,create) +#endif + +/* Replace: 1 */ +#ifndef get_cv +# define get_cv perl_get_cv +#endif + +#ifndef get_sv +# define get_sv perl_get_sv +#endif + +#ifndef get_av +# define get_av perl_get_av +#endif + +#ifndef get_hv +# define get_hv perl_get_hv +#endif + +/* Replace: 0 */ +#ifndef dUNDERBAR +# define dUNDERBAR dNOOP +#endif + +#ifndef UNDERBAR +# define UNDERBAR DEFSV +#endif +#ifndef dAX +# define dAX I32 ax = MARK - PL_stack_base + 1 +#endif + +#ifndef dITEMS +# define dITEMS I32 items = SP - MARK +#endif +#ifndef dXSTARG +# define dXSTARG SV * targ = sv_newmortal() +#endif +#ifndef dAXMARK +# define dAXMARK I32 ax = POPMARK; \ + register SV ** const mark = PL_stack_base + ax++ +#endif +#ifndef XSprePUSH +# define XSprePUSH (sp = PL_stack_base + ax - 1) +#endif + +#if (PERL_BCDVERSION < 0x5005000) +# undef XSRETURN +# define XSRETURN(off) \ + STMT_START { \ + PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ + return; \ + } STMT_END +#endif +#ifndef XSPROTO +# define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef SVfARG +# define SVfARG(p) ((void*)(p)) +#endif +#ifndef PERL_ABS +# define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +#endif +#ifndef dVAR +# define dVAR dNOOP +#endif +#ifndef SVf +# define SVf "_" +#endif +#ifndef UTF8_MAXBYTES +# define UTF8_MAXBYTES UTF8_MAXLEN +#endif +#ifndef CPERLscope +# define CPERLscope(x) x +#endif +#ifndef PERL_HASH +# define PERL_HASH(hash,str,len) \ + STMT_START { \ + const char *s_PeRlHaSh = str; \ + I32 i_PeRlHaSh = len; \ + U32 hash_PeRlHaSh = 0; \ + while (i_PeRlHaSh--) \ + hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ + (hash) = hash_PeRlHaSh; \ + } STMT_END +#endif + +#ifndef PERLIO_FUNCS_DECL +# ifdef PERLIO_FUNCS_CONST +# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) +# else +# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs +# define PERLIO_FUNCS_CAST(funcs) (funcs) +# endif +#endif + +/* provide these typedefs for older perls */ +#if (PERL_BCDVERSION < 0x5009003) + +# ifdef ARGSproto +typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); +# else +typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); +# endif + +typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*); + +#endif +#ifndef isPSXSPC +# define isPSXSPC(c) (isSPACE(c) || (c) == '\v') +#endif + +#ifndef isBLANK +# define isBLANK(c) ((c) == ' ' || (c) == '\t') +#endif + +#ifdef EBCDIC +#ifndef isALNUMC +# define isALNUMC(c) isalnum(c) +#endif + +#ifndef isASCII +# define isASCII(c) isascii(c) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) iscntrl(c) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) isgraph(c) +#endif + +#ifndef isPRINT +# define isPRINT(c) isprint(c) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) ispunct(c) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) isxdigit(c) +#endif + +#else +# if (PERL_BCDVERSION < 0x5010000) +/* Hint: isPRINT + * The implementation in older perl versions includes all of the + * isSPACE() characters, which is wrong. The version provided by + * Devel::PPPort always overrides a present buggy version. + */ +# undef isPRINT +# endif +#ifndef isALNUMC +# define isALNUMC(c) (isALPHA(c) || isDIGIT(c)) +#endif + +#ifndef isASCII +# define isASCII(c) ((c) <= 127) +#endif + +#ifndef isCNTRL +# define isCNTRL(c) ((c) < ' ' || (c) == 127) +#endif + +#ifndef isGRAPH +# define isGRAPH(c) (isALNUM(c) || isPUNCT(c)) +#endif + +#ifndef isPRINT +# define isPRINT(c) (((c) >= 32 && (c) < 127)) +#endif + +#ifndef isPUNCT +# define isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) +#endif + +#ifndef isXDIGIT +# define isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) +#endif + +#endif + +#ifndef PERL_SIGNALS_UNSAFE_FLAG + +#define PERL_SIGNALS_UNSAFE_FLAG 0x0001 + +#if (PERL_BCDVERSION < 0x5008000) +# define D_PPP_PERL_SIGNALS_INIT PERL_SIGNALS_UNSAFE_FLAG +#else +# define D_PPP_PERL_SIGNALS_INIT 0 +#endif + +#if defined(NEED_PL_signals) +static U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#elif defined(NEED_PL_signals_GLOBAL) +U32 DPPP_(my_PL_signals) = D_PPP_PERL_SIGNALS_INIT; +#else +extern U32 DPPP_(my_PL_signals); +#endif +#define PL_signals DPPP_(my_PL_signals) + +#endif + +/* Hint: PL_ppaddr + * Calling an op via PL_ppaddr requires passing a context argument + * for threaded builds. Since the context argument is different for + * 5.005 perls, you can use aTHXR (supplied by ppport.h), which will + * automatically be defined as the correct argument. + */ + +#if (PERL_BCDVERSION <= 0x5005005) +/* Replace: 1 */ +# define PL_ppaddr ppaddr +# define PL_no_modify no_modify +/* Replace: 0 */ +#endif + +#if (PERL_BCDVERSION <= 0x5004005) +/* Replace: 1 */ +# define PL_DBsignal DBsignal +# define PL_DBsingle DBsingle +# define PL_DBsub DBsub +# define PL_DBtrace DBtrace +# define PL_Sv Sv +# define PL_bufend bufend +# define PL_bufptr bufptr +# define PL_compiling compiling +# define PL_copline copline +# define PL_curcop curcop +# define PL_curstash curstash +# define PL_debstash debstash +# define PL_defgv defgv +# define PL_diehook diehook +# define PL_dirty dirty +# define PL_dowarn dowarn +# define PL_errgv errgv +# define PL_error_count error_count +# define PL_expect expect +# define PL_hexdigit hexdigit +# define PL_hints hints +# define PL_in_my in_my +# define PL_laststatval laststatval +# define PL_lex_state lex_state +# define PL_lex_stuff lex_stuff +# define PL_linestr linestr +# define PL_na na +# define PL_perl_destruct_level perl_destruct_level +# define PL_perldb perldb +# define PL_rsfp_filters rsfp_filters +# define PL_rsfp rsfp +# define PL_stack_base stack_base +# define PL_stack_sp stack_sp +# define PL_statcache statcache +# define PL_stdingv stdingv +# define PL_sv_arenaroot sv_arenaroot +# define PL_sv_no sv_no +# define PL_sv_undef sv_undef +# define PL_sv_yes sv_yes +# define PL_tainted tainted +# define PL_tainting tainting +# define PL_tokenbuf tokenbuf +/* Replace: 0 */ +#endif + +/* Warning: PL_parser + * For perl versions earlier than 5.9.5, this is an always + * non-NULL dummy. Also, it cannot be dereferenced. Don't + * use it if you can avoid is and unless you absolutely know + * what you're doing. + * If you always check that PL_parser is non-NULL, you can + * define DPPP_PL_parser_NO_DUMMY to avoid the creation of + * a dummy parser structure. + */ + +#if (PERL_BCDVERSION >= 0x5009005) +# ifdef DPPP_PL_parser_NO_DUMMY +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (croak("panic: PL_parser == NULL in %s:%d", \ + __FILE__, __LINE__), (yy_parser *) NULL))->var) +# else +# ifdef DPPP_PL_parser_NO_DUMMY_WARNING +# define D_PPP_parser_dummy_warning(var) +# else +# define D_PPP_parser_dummy_warning(var) \ + warn("warning: dummy PL_" #var " used in %s:%d", __FILE__, __LINE__), +# endif +# define D_PPP_my_PL_parser_var(var) ((PL_parser ? PL_parser : \ + (D_PPP_parser_dummy_warning(var) &DPPP_(dummy_PL_parser)))->var) +#if defined(NEED_PL_parser) +static yy_parser DPPP_(dummy_PL_parser); +#elif defined(NEED_PL_parser_GLOBAL) +yy_parser DPPP_(dummy_PL_parser); +#else +extern yy_parser DPPP_(dummy_PL_parser); +#endif + +# endif + +/* PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf depends on PL_parser */ +/* Warning: PL_expect, PL_copline, PL_rsfp, PL_rsfp_filters, PL_linestr, PL_bufptr, PL_bufend, PL_lex_state, PL_lex_stuff, PL_tokenbuf + * Do not use this variable unless you know exactly what you're + * doint. It is internal to the perl parser and may change or even + * be removed in the future. As of perl 5.9.5, you have to check + * for (PL_parser != NULL) for this variable to have any effect. + * An always non-NULL PL_parser dummy is provided for earlier + * perl versions. + * If PL_parser is NULL when you try to access this variable, a + * dummy is being accessed instead and a warning is issued unless + * you define DPPP_PL_parser_NO_DUMMY_WARNING. + * If DPPP_PL_parser_NO_DUMMY is defined, the code trying to access + * this variable will croak with a panic message. + */ + +# define PL_expect D_PPP_my_PL_parser_var(expect) +# define PL_copline D_PPP_my_PL_parser_var(copline) +# define PL_rsfp D_PPP_my_PL_parser_var(rsfp) +# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters) +# define PL_linestr D_PPP_my_PL_parser_var(linestr) +# define PL_bufptr D_PPP_my_PL_parser_var(bufptr) +# define PL_bufend D_PPP_my_PL_parser_var(bufend) +# define PL_lex_state D_PPP_my_PL_parser_var(lex_state) +# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff) +# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf) +# define PL_in_my D_PPP_my_PL_parser_var(in_my) +# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash) +# define PL_error_count D_PPP_my_PL_parser_var(error_count) + + +#else + +/* ensure that PL_parser != NULL and cannot be dereferenced */ +# define PL_parser ((void *) 1) + +#endif +#ifndef mPUSHs +# define mPUSHs(s) PUSHs(sv_2mortal(s)) +#endif + +#ifndef PUSHmortal +# define PUSHmortal PUSHs(sv_newmortal()) +#endif + +#ifndef mPUSHp +# define mPUSHp(p,l) sv_setpvn(PUSHmortal, (p), (l)) +#endif + +#ifndef mPUSHn +# define mPUSHn(n) sv_setnv(PUSHmortal, (NV)(n)) +#endif + +#ifndef mPUSHi +# define mPUSHi(i) sv_setiv(PUSHmortal, (IV)(i)) +#endif + +#ifndef mPUSHu +# define mPUSHu(u) sv_setuv(PUSHmortal, (UV)(u)) +#endif +#ifndef mXPUSHs +# define mXPUSHs(s) XPUSHs(sv_2mortal(s)) +#endif + +#ifndef XPUSHmortal +# define XPUSHmortal XPUSHs(sv_newmortal()) +#endif + +#ifndef mXPUSHp +# define mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn(PUSHmortal, (p), (l)); } STMT_END +#endif + +#ifndef mXPUSHn +# define mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv(PUSHmortal, (NV)(n)); } STMT_END +#endif + +#ifndef mXPUSHi +# define mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv(PUSHmortal, (IV)(i)); } STMT_END +#endif + +#ifndef mXPUSHu +# define mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv(PUSHmortal, (UV)(u)); } STMT_END +#endif + +/* Replace: 1 */ +#ifndef call_sv +# define call_sv perl_call_sv +#endif + +#ifndef call_pv +# define call_pv perl_call_pv +#endif + +#ifndef call_argv +# define call_argv perl_call_argv +#endif + +#ifndef call_method +# define call_method perl_call_method +#endif +#ifndef eval_sv +# define eval_sv perl_eval_sv +#endif + +/* Replace: 0 */ +#ifndef PERL_LOADMOD_DENY +# define PERL_LOADMOD_DENY 0x1 +#endif + +#ifndef PERL_LOADMOD_NOIMPORT +# define PERL_LOADMOD_NOIMPORT 0x2 +#endif + +#ifndef PERL_LOADMOD_IMPORT_OPS +# define PERL_LOADMOD_IMPORT_OPS 0x4 +#endif + +#ifndef G_METHOD +# define G_METHOD 64 +# ifdef call_sv +# undef call_sv +# endif +# if (PERL_BCDVERSION < 0x5006000) +# define call_sv(sv, flags) ((flags) & G_METHOD ? perl_call_method((char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : perl_call_sv(sv, flags)) +# else +# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \ + (flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags)) +# endif +#endif + +/* Replace perl_eval_pv with eval_pv */ + +#ifndef eval_pv +#if defined(NEED_eval_pv) +static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +static +#else +extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error); +#endif + +#ifdef eval_pv +# undef eval_pv +#endif +#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b) +#define Perl_eval_pv DPPP_(my_eval_pv) + +#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) + +SV* +DPPP_(my_eval_pv)(char *p, I32 croak_on_error) +{ + dSP; + SV* sv = newSVpv(p, 0); + + PUSHMARK(sp); + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); + + SPAGAIN; + sv = POPs; + PUTBACK; + + if (croak_on_error && SvTRUE(GvSV(errgv))) + croak(SvPVx(GvSV(errgv), na)); + + return sv; +} + +#endif +#endif + +#ifndef vload_module +#if defined(NEED_vload_module) +static void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +static +#else +extern void DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args); +#endif + +#ifdef vload_module +# undef vload_module +#endif +#define vload_module(a,b,c,d) DPPP_(my_vload_module)(aTHX_ a,b,c,d) +#define Perl_vload_module DPPP_(my_vload_module) + +#if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) + +void +DPPP_(my_vload_module)(U32 flags, SV *name, SV *ver, va_list *args) +{ + dTHR; + dVAR; + OP *veop, *imop; + + OP * const modname = newSVOP(OP_CONST, 0, name); + /* 5.005 has a somewhat hacky force_normal that doesn't croak on + SvREADONLY() if PL_compiling is true. Current perls take care in + ck_require() to correctly turn off SvREADONLY before calling + force_normal_flags(). This seems a better fix than fudging PL_compiling + */ + SvREADONLY_off(((SVOP*)modname)->op_sv); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = NULL; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = NULL; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + const line_t ocopline = PL_copline; + COP * const ocurcop = PL_curcop; + const int oexpect = PL_expect; + +#if (PERL_BCDVERSION >= 0x5004000) + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); +#else + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(), + modname, imop); +#endif + PL_expect = oexpect; + PL_copline = ocopline; + PL_curcop = ocurcop; + } +} + +#endif +#endif + +#ifndef load_module +#if defined(NEED_load_module) +static void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +static +#else +extern void DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...); +#endif + +#ifdef load_module +# undef load_module +#endif +#define load_module DPPP_(my_load_module) +#define Perl_load_module DPPP_(my_load_module) + +#if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) + +void +DPPP_(my_load_module)(U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#endif +#endif +#ifndef newRV_inc +# define newRV_inc(sv) newRV(sv) /* Replace */ +#endif + +#ifndef newRV_noinc +#if defined(NEED_newRV_noinc) +static SV * DPPP_(my_newRV_noinc)(SV *sv); +static +#else +extern SV * DPPP_(my_newRV_noinc)(SV *sv); +#endif + +#ifdef newRV_noinc +# undef newRV_noinc +#endif +#define newRV_noinc(a) DPPP_(my_newRV_noinc)(aTHX_ a) +#define Perl_newRV_noinc DPPP_(my_newRV_noinc) + +#if defined(NEED_newRV_noinc) || defined(NEED_newRV_noinc_GLOBAL) +SV * +DPPP_(my_newRV_noinc)(SV *sv) +{ + SV *rv = (SV *)newRV(sv); + SvREFCNT_dec(sv); + return rv; +} +#endif +#endif + +/* Hint: newCONSTSUB + * Returns a CV* as of perl-5.7.1. This return value is not supported + * by Devel::PPPort. + */ + +/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */ +#if (PERL_BCDVERSION < 0x5004063) && (PERL_BCDVERSION != 0x5004005) +#if defined(NEED_newCONSTSUB) +static void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +static +#else +extern void DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv); +#endif + +#ifdef newCONSTSUB +# undef newCONSTSUB +#endif +#define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) +#define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) + +#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) + +/* This is just a trick to avoid a dependency of newCONSTSUB on PL_parser */ +/* (There's no PL_parser in perl < 5.005, so this is completely safe) */ +#define D_PPP_PL_copline PL_copline + +void +DPPP_(my_newCONSTSUB)(HV *stash, const char *name, SV *sv) +{ + U32 oldhints = PL_hints; + HV *old_cop_stash = PL_curcop->cop_stash; + HV *old_curstash = PL_curstash; + line_t oldline = PL_curcop->cop_line; + PL_curcop->cop_line = D_PPP_PL_copline; + + PL_hints &= ~HINT_BLOCK_SCOPE; + if (stash) + PL_curstash = PL_curcop->cop_stash = stash; + + newSUB( + +#if (PERL_BCDVERSION < 0x5003022) + start_subparse(), +#elif (PERL_BCDVERSION == 0x5003022) + start_subparse(0), +#else /* 5.003_23 onwards */ + start_subparse(FALSE, 0), +#endif + + newSVOP(OP_CONST, 0, newSVpv((char *) name, 0)), + newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ + newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) + ); + + PL_hints = oldhints; + PL_curcop->cop_stash = old_cop_stash; + PL_curstash = old_curstash; + PL_curcop->cop_line = oldline; +} +#endif +#endif + +/* + * Boilerplate macros for initializing and accessing interpreter-local + * data from C. All statics in extensions should be reworked to use + * this, if you want to make the extension thread-safe. See ext/re/re.xs + * for an example of the use of these macros. + * + * Code that uses these macros is responsible for the following: + * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts" + * 2. Declare a typedef named my_cxt_t that is a structure that contains + * all the data that needs to be interpreter-local. + * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t. + * 4. Use the MY_CXT_INIT macro such that it is called exactly once + * (typically put in the BOOT: section). + * 5. Use the members of the my_cxt_t structure everywhere as + * MY_CXT.member. + * 6. Use the dMY_CXT macro (a declaration) in all the functions that + * access MY_CXT. + */ + +#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \ + defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT) + +#ifndef START_MY_CXT + +/* This must appear in all extensions that define a my_cxt_t structure, + * right after the definition (i.e. at file scope). The non-threads + * case below uses it to declare the data as static. */ +#define START_MY_CXT + +#if (PERL_BCDVERSION < 0x5004068) +/* Fetches the SV that keeps the per-interpreter data. */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE) +#else /* >= perl5.004_68 */ +#define dMY_CXT_SV \ + SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \ + sizeof(MY_CXT_KEY)-1, TRUE) +#endif /* < perl5.004_68 */ + +/* This declaration should be used within all functions that use the + * interpreter-local data. */ +#define dMY_CXT \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv)) + +/* Creates and zeroes the per-interpreter data. + * (We allocate my_cxtp in a Perl SV so that it will be released when + * the interpreter goes away.) */ +#define MY_CXT_INIT \ + dMY_CXT_SV; \ + /* newSV() allocates one more than needed */ \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Zero(my_cxtp, 1, my_cxt_t); \ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) + +/* This macro must be used to access members of the my_cxt_t structure. + * e.g. MYCXT.some_data */ +#define MY_CXT (*my_cxtp) + +/* Judicious use of these macros can reduce the number of times dMY_CXT + * is used. Use is similar to pTHX, aTHX etc. */ +#define pMY_CXT my_cxt_t *my_cxtp +#define pMY_CXT_ pMY_CXT, +#define _pMY_CXT ,pMY_CXT +#define aMY_CXT my_cxtp +#define aMY_CXT_ aMY_CXT, +#define _aMY_CXT ,aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +/* Clones the per-interpreter data. */ +#define MY_CXT_CLONE \ + dMY_CXT_SV; \ + my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\ + Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\ + sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) +#endif + +#else /* single interpreter */ + +#ifndef START_MY_CXT + +#define START_MY_CXT static my_cxt_t my_cxt; +#define dMY_CXT_SV dNOOP +#define dMY_CXT dNOOP +#define MY_CXT_INIT NOOP +#define MY_CXT my_cxt + +#define pMY_CXT void +#define pMY_CXT_ +#define _pMY_CXT +#define aMY_CXT +#define aMY_CXT_ +#define _aMY_CXT + +#endif /* START_MY_CXT */ + +#ifndef MY_CXT_CLONE +#define MY_CXT_CLONE NOOP +#endif + +#endif + +#ifndef IVdf +# if IVSIZE == LONGSIZE +# define IVdf "ld" +# define UVuf "lu" +# define UVof "lo" +# define UVxf "lx" +# define UVXf "lX" +# else +# if IVSIZE == INTSIZE +# define IVdf "d" +# define UVuf "u" +# define UVof "o" +# define UVxf "x" +# define UVXf "X" +# endif +# endif +#endif + +#ifndef NVef +# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \ + defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000) + /* Not very likely, but let's try anyway. */ +# define NVef PERL_PRIeldbl +# define NVff PERL_PRIfldbl +# define NVgf PERL_PRIgldbl +# else +# define NVef "e" +# define NVff "f" +# define NVgf "g" +# endif +#endif + +#ifndef SvREFCNT_inc +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (SvREFCNT(_sv))++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc(sv) \ + ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_simple +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_simple(sv) \ + ({ \ + if (sv) \ + (SvREFCNT(sv))++; \ + (SV *)(sv); \ + }) +# else +# define SvREFCNT_inc_simple(sv) \ + ((sv) ? (SvREFCNT(sv)++,(SV*)(sv)) : NULL) +# endif +#endif + +#ifndef SvREFCNT_inc_NN +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_NN(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + SvREFCNT(_sv)++; \ + _sv; \ + }) +# else +# define SvREFCNT_inc_NN(sv) \ + (PL_Sv=(SV*)(sv),++(SvREFCNT(PL_Sv)),PL_Sv) +# endif +#endif + +#ifndef SvREFCNT_inc_void +# ifdef PERL_USE_GCC_BRACE_GROUPS +# define SvREFCNT_inc_void(sv) \ + ({ \ + SV * const _sv = (SV*)(sv); \ + if (_sv) \ + (void)(SvREFCNT(_sv)++); \ + }) +# else +# define SvREFCNT_inc_void(sv) \ + (void)((PL_Sv=(SV*)(sv)) ? ++(SvREFCNT(PL_Sv)) : 0) +# endif +#endif +#ifndef SvREFCNT_inc_simple_void +# define SvREFCNT_inc_simple_void(sv) STMT_START { if (sv) SvREFCNT(sv)++; } STMT_END +#endif + +#ifndef SvREFCNT_inc_simple_NN +# define SvREFCNT_inc_simple_NN(sv) (++SvREFCNT(sv), (SV*)(sv)) +#endif + +#ifndef SvREFCNT_inc_void_NN +# define SvREFCNT_inc_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef SvREFCNT_inc_simple_void_NN +# define SvREFCNT_inc_simple_void_NN(sv) (void)(++SvREFCNT((SV*)(sv))) +#endif + +#ifndef newSV_type + +#if defined(NEED_newSV_type) +static SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +static +#else +extern SV* DPPP_(my_newSV_type)(pTHX_ svtype const t); +#endif + +#ifdef newSV_type +# undef newSV_type +#endif +#define newSV_type(a) DPPP_(my_newSV_type)(aTHX_ a) +#define Perl_newSV_type DPPP_(my_newSV_type) + +#if defined(NEED_newSV_type) || defined(NEED_newSV_type_GLOBAL) + +SV* +DPPP_(my_newSV_type)(pTHX_ svtype const t) +{ + SV* const sv = newSV(0); + sv_upgrade(sv, t); + return sv; +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5006000) +# define D_PPP_CONSTPV_ARG(x) ((char *) (x)) +#else +# define D_PPP_CONSTPV_ARG(x) (x) +#endif +#ifndef newSVpvn +# define newSVpvn(data,len) ((data) \ + ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \ + : newSV(0)) +#endif +#ifndef newSVpvn_utf8 +# define newSVpvn_utf8(s, len, u) newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) +#endif +#ifndef SVf_UTF8 +# define SVf_UTF8 0 +#endif + +#ifndef newSVpvn_flags + +#if defined(NEED_newSVpvn_flags) +static SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +static +#else +extern SV * DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags); +#endif + +#ifdef newSVpvn_flags +# undef newSVpvn_flags +#endif +#define newSVpvn_flags(a,b,c) DPPP_(my_newSVpvn_flags)(aTHX_ a,b,c) +#define Perl_newSVpvn_flags DPPP_(my_newSVpvn_flags) + +#if defined(NEED_newSVpvn_flags) || defined(NEED_newSVpvn_flags_GLOBAL) + +SV * +DPPP_(my_newSVpvn_flags)(pTHX_ const char *s, STRLEN len, U32 flags) +{ + SV *sv = newSVpvn(D_PPP_CONSTPV_ARG(s), len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + +#endif + +#endif + +/* Backwards compatibility stuff... :-( */ +#if !defined(NEED_sv_2pv_flags) && defined(NEED_sv_2pv_nolen) +# define NEED_sv_2pv_flags +#endif +#if !defined(NEED_sv_2pv_flags_GLOBAL) && defined(NEED_sv_2pv_nolen_GLOBAL) +# define NEED_sv_2pv_flags_GLOBAL +#endif + +/* Hint: sv_2pv_nolen + * Use the SvPV_nolen() or SvPV_nolen_const() macros instead of sv_2pv_nolen(). + */ +#ifndef sv_2pv_nolen +# define sv_2pv_nolen(sv) SvPV_nolen(sv) +#endif + +#ifdef SvPVbyte + +/* Hint: SvPVbyte + * Does not work in perl-5.6.1, ppport.h implements a version + * borrowed from perl-5.7.3. + */ + +#if (PERL_BCDVERSION < 0x5007000) + +#if defined(NEED_sv_2pvbyte) +static char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +static +#else +extern char * DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp); +#endif + +#ifdef sv_2pvbyte +# undef sv_2pvbyte +#endif +#define sv_2pvbyte(a,b) DPPP_(my_sv_2pvbyte)(aTHX_ a,b) +#define Perl_sv_2pvbyte DPPP_(my_sv_2pvbyte) + +#if defined(NEED_sv_2pvbyte) || defined(NEED_sv_2pvbyte_GLOBAL) + +char * +DPPP_(my_sv_2pvbyte)(pTHX_ SV *sv, STRLEN *lp) +{ + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); +} + +#endif + +/* Hint: sv_2pvbyte + * Use the SvPVbyte() macro instead of sv_2pvbyte(). + */ + +#undef SvPVbyte + +#define SvPVbyte(sv, lp) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp)) + +#endif + +#else + +# define SvPVbyte SvPV +# define sv_2pvbyte sv_2pv + +#endif +#ifndef sv_2pvbyte_nolen +# define sv_2pvbyte_nolen(sv) sv_2pv_nolen(sv) +#endif + +/* Hint: sv_pvn + * Always use the SvPV() macro instead of sv_pvn(). + */ + +/* Hint: sv_pvn_force + * Always use the SvPV_force() macro instead of sv_pvn_force(). + */ + +/* If these are undefined, they're not handled by the core anyway */ +#ifndef SV_IMMEDIATE_UNREF +# define SV_IMMEDIATE_UNREF 0 +#endif + +#ifndef SV_GMAGIC +# define SV_GMAGIC 0 +#endif + +#ifndef SV_COW_DROP_PV +# define SV_COW_DROP_PV 0 +#endif + +#ifndef SV_UTF8_NO_ENCODING +# define SV_UTF8_NO_ENCODING 0 +#endif + +#ifndef SV_NOSTEAL +# define SV_NOSTEAL 0 +#endif + +#ifndef SV_CONST_RETURN +# define SV_CONST_RETURN 0 +#endif + +#ifndef SV_MUTABLE_RETURN +# define SV_MUTABLE_RETURN 0 +#endif + +#ifndef SV_SMAGIC +# define SV_SMAGIC 0 +#endif + +#ifndef SV_HAS_TRAILING_NUL +# define SV_HAS_TRAILING_NUL 0 +#endif + +#ifndef SV_COW_SHARED_HASH_KEYS +# define SV_COW_SHARED_HASH_KEYS 0 +#endif + +#if (PERL_BCDVERSION < 0x5007002) + +#if defined(NEED_sv_2pv_flags) +static char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_2pv_flags +# undef sv_2pv_flags +#endif +#define sv_2pv_flags(a,b,c) DPPP_(my_sv_2pv_flags)(aTHX_ a,b,c) +#define Perl_sv_2pv_flags DPPP_(my_sv_2pv_flags) + +#if defined(NEED_sv_2pv_flags) || defined(NEED_sv_2pv_flags_GLOBAL) + +char * +DPPP_(my_sv_2pv_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_2pv(sv, lp ? lp : &n_a); +} + +#endif + +#if defined(NEED_sv_pvn_force_flags) +static char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +static +#else +extern char * DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags); +#endif + +#ifdef sv_pvn_force_flags +# undef sv_pvn_force_flags +#endif +#define sv_pvn_force_flags(a,b,c) DPPP_(my_sv_pvn_force_flags)(aTHX_ a,b,c) +#define Perl_sv_pvn_force_flags DPPP_(my_sv_pvn_force_flags) + +#if defined(NEED_sv_pvn_force_flags) || defined(NEED_sv_pvn_force_flags_GLOBAL) + +char * +DPPP_(my_sv_pvn_force_flags)(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ + STRLEN n_a = (STRLEN) flags; + return sv_pvn_force(sv, lp ? lp : &n_a); +} + +#endif + +#endif + +#if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) +# define DPPP_SVPV_NOLEN_LP_ARG &PL_na +#else +# define DPPP_SVPV_NOLEN_LP_ARG 0 +#endif +#ifndef SvPV_const +# define SvPV_const(sv, lp) SvPV_flags_const(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_mutable +# define SvPV_mutable(sv, lp) SvPV_flags_mutable(sv, lp, SV_GMAGIC) +#endif +#ifndef SvPV_flags +# define SvPV_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_flags_const +# define SvPV_flags_const(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_const(sv)) : \ + (const char*) sv_2pv_flags(sv, &lp, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_const_nolen +# define SvPV_flags_const_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : \ + (const char*) sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags|SV_CONST_RETURN)) +#endif +#ifndef SvPV_flags_mutable +# define SvPV_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) : \ + sv_2pv_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_force +# define SvPV_force(sv, lp) SvPV_force_flags(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nolen +# define SvPV_force_nolen(sv) SvPV_force_flags_nolen(sv, SV_GMAGIC) +#endif + +#ifndef SvPV_force_mutable +# define SvPV_force_mutable(sv, lp) SvPV_force_flags_mutable(sv, lp, SV_GMAGIC) +#endif + +#ifndef SvPV_force_nomg +# define SvPV_force_nomg(sv, lp) SvPV_force_flags(sv, lp, 0) +#endif + +#ifndef SvPV_force_nomg_nolen +# define SvPV_force_nomg_nolen(sv) SvPV_force_flags_nolen(sv, 0) +#endif +#ifndef SvPV_force_flags +# define SvPV_force_flags(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force_flags(sv, &lp, flags)) +#endif +#ifndef SvPV_force_flags_nolen +# define SvPV_force_flags_nolen(sv, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? SvPVX(sv) : sv_pvn_force_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, flags)) +#endif +#ifndef SvPV_force_flags_mutable +# define SvPV_force_flags_mutable(sv, lp, flags) \ + ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \ + ? ((lp = SvCUR(sv)), SvPVX_mutable(sv)) \ + : sv_pvn_force_flags(sv, &lp, flags|SV_MUTABLE_RETURN)) +#endif +#ifndef SvPV_nolen +# define SvPV_nolen(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC)) +#endif +#ifndef SvPV_nolen_const +# define SvPV_nolen_const(sv) \ + ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \ + ? SvPVX_const(sv) : sv_2pv_flags(sv, DPPP_SVPV_NOLEN_LP_ARG, SV_GMAGIC|SV_CONST_RETURN)) +#endif +#ifndef SvPV_nomg +# define SvPV_nomg(sv, lp) SvPV_flags(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const +# define SvPV_nomg_const(sv, lp) SvPV_flags_const(sv, lp, 0) +#endif + +#ifndef SvPV_nomg_const_nolen +# define SvPV_nomg_const_nolen(sv) SvPV_flags_const_nolen(sv, 0) +#endif +#ifndef SvPV_renew +# define SvPV_renew(sv,n) STMT_START { SvLEN_set(sv, n); \ + SvPV_set((sv), (char *) saferealloc( \ + (Malloc_t)SvPVX(sv), (MEM_SIZE)((n)))); \ + } STMT_END +#endif +#ifndef SvMAGIC_set +# define SvMAGIC_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_magic = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5009003) +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*) (0 + SvPVX(sv))) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) (0 + SvPVX(sv)) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + (((XRV*) SvANY(sv))->xrv_rv = (val)); } STMT_END +#endif + +#else +#ifndef SvPVX_const +# define SvPVX_const(sv) ((const char*)((sv)->sv_u.svu_pv)) +#endif + +#ifndef SvPVX_mutable +# define SvPVX_mutable(sv) ((sv)->sv_u.svu_pv) +#endif +#ifndef SvRV_set +# define SvRV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_RV); \ + ((sv)->sv_u.svu_rv = (val)); } STMT_END +#endif + +#endif +#ifndef SvSTASH_set +# define SvSTASH_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) >= SVt_PVMG); \ + (((XPVMG*) SvANY(sv))->xmg_stash = (val)); } STMT_END +#endif + +#if (PERL_BCDVERSION < 0x5004000) +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVIV*) SvANY(sv))->xiv_iv = (IV) (val)); } STMT_END +#endif + +#else +#ifndef SvUV_set +# define SvUV_set(sv, val) \ + STMT_START { assert(SvTYPE(sv) == SVt_IV || SvTYPE(sv) >= SVt_PVIV); \ + (((XPVUV*) SvANY(sv))->xuv_uv = (val)); } STMT_END +#endif + +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) +#if defined(NEED_vnewSVpvf) +static SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +static +#else +extern SV * DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args); +#endif + +#ifdef vnewSVpvf +# undef vnewSVpvf +#endif +#define vnewSVpvf(a,b) DPPP_(my_vnewSVpvf)(aTHX_ a,b) +#define Perl_vnewSVpvf DPPP_(my_vnewSVpvf) + +#if defined(NEED_vnewSVpvf) || defined(NEED_vnewSVpvf_GLOBAL) + +SV * +DPPP_(my_vnewSVpvf)(pTHX_ const char *pat, va_list *args) +{ + register SV *sv = newSV(0); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +#endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf) +# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf) +# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)) +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg) +#if defined(NEED_sv_catpvf_mg) +static void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) + +#if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_catpvf_mg_nocontext) +#if defined(NEED_sv_catpvf_mg_nocontext) +static void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) +#define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) + +#if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_catpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_catpvf_mg depends on sv_catpvf_mg_nocontext */ +#ifndef sv_catpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext +# else +# define sv_catpvf_mg Perl_sv_catpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vcatpvf_mg) +# define sv_vcatpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg) +#if defined(NEED_sv_setpvf_mg) +static void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...); +#endif + +#define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) + +#if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg)(pTHX_ SV *sv, const char *pat, ...) +{ + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif + +#ifdef PERL_IMPLICIT_CONTEXT +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_setpvf_mg_nocontext) +#if defined(NEED_sv_setpvf_mg_nocontext) +static void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +static +#else +extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...); +#endif + +#define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) +#define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) + +#if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) + +void +DPPP_(my_sv_setpvf_mg_nocontext)(SV *sv, const char *pat, ...) +{ + dTHX; + va_list args; + va_start(args, pat); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + SvSETMAGIC(sv); + va_end(args); +} + +#endif +#endif +#endif + +/* sv_setpvf_mg depends on sv_setpvf_mg_nocontext */ +#ifndef sv_setpvf_mg +# ifdef PERL_IMPLICIT_CONTEXT +# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext +# else +# define sv_setpvf_mg Perl_sv_setpvf_mg +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(sv_vsetpvf_mg) +# define sv_vsetpvf_mg(sv, pat, args) \ + STMT_START { \ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \ + SvSETMAGIC(sv); \ + } STMT_END +#endif + +#ifndef newSVpvn_share + +#if defined(NEED_newSVpvn_share) +static SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +static +#else +extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash); +#endif + +#ifdef newSVpvn_share +# undef newSVpvn_share +#endif +#define newSVpvn_share(a,b,c) DPPP_(my_newSVpvn_share)(aTHX_ a,b,c) +#define Perl_newSVpvn_share DPPP_(my_newSVpvn_share) + +#if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) + +SV * +DPPP_(my_newSVpvn_share)(pTHX_ const char *src, I32 len, U32 hash) +{ + SV *sv; + if (len < 0) + len = -len; + if (!hash) + PERL_HASH(hash, (char*) src, len); + sv = newSVpvn((char *) src, len); + sv_upgrade(sv, SVt_PVIV); + SvIVX(sv) = hash; + SvREADONLY_on(sv); + SvPOK_on(sv); + return sv; +} + +#endif + +#endif +#ifndef SvSHARED_HASH +# define SvSHARED_HASH(sv) (0 + SvUVX(sv)) +#endif +#ifndef HvNAME_get +# define HvNAME_get(hv) HvNAME(hv) +#endif +#ifndef HvNAMELEN_get +# define HvNAMELEN_get(hv) (HvNAME_get(hv) ? (I32)strlen(HvNAME_get(hv)) : 0) +#endif +#ifndef GvSVn +# define GvSVn(gv) GvSV(gv) +#endif + +#ifndef isGV_with_GP +# define isGV_with_GP(gv) isGV(gv) +#endif +#ifndef WARN_ALL +# define WARN_ALL 0 +#endif + +#ifndef WARN_CLOSURE +# define WARN_CLOSURE 1 +#endif + +#ifndef WARN_DEPRECATED +# define WARN_DEPRECATED 2 +#endif + +#ifndef WARN_EXITING +# define WARN_EXITING 3 +#endif + +#ifndef WARN_GLOB +# define WARN_GLOB 4 +#endif + +#ifndef WARN_IO +# define WARN_IO 5 +#endif + +#ifndef WARN_CLOSED +# define WARN_CLOSED 6 +#endif + +#ifndef WARN_EXEC +# define WARN_EXEC 7 +#endif + +#ifndef WARN_LAYER +# define WARN_LAYER 8 +#endif + +#ifndef WARN_NEWLINE +# define WARN_NEWLINE 9 +#endif + +#ifndef WARN_PIPE +# define WARN_PIPE 10 +#endif + +#ifndef WARN_UNOPENED +# define WARN_UNOPENED 11 +#endif + +#ifndef WARN_MISC +# define WARN_MISC 12 +#endif + +#ifndef WARN_NUMERIC +# define WARN_NUMERIC 13 +#endif + +#ifndef WARN_ONCE +# define WARN_ONCE 14 +#endif + +#ifndef WARN_OVERFLOW +# define WARN_OVERFLOW 15 +#endif + +#ifndef WARN_PACK +# define WARN_PACK 16 +#endif + +#ifndef WARN_PORTABLE +# define WARN_PORTABLE 17 +#endif + +#ifndef WARN_RECURSION +# define WARN_RECURSION 18 +#endif + +#ifndef WARN_REDEFINE +# define WARN_REDEFINE 19 +#endif + +#ifndef WARN_REGEXP +# define WARN_REGEXP 20 +#endif + +#ifndef WARN_SEVERE +# define WARN_SEVERE 21 +#endif + +#ifndef WARN_DEBUGGING +# define WARN_DEBUGGING 22 +#endif + +#ifndef WARN_INPLACE +# define WARN_INPLACE 23 +#endif + +#ifndef WARN_INTERNAL +# define WARN_INTERNAL 24 +#endif + +#ifndef WARN_MALLOC +# define WARN_MALLOC 25 +#endif + +#ifndef WARN_SIGNAL +# define WARN_SIGNAL 26 +#endif + +#ifndef WARN_SUBSTR +# define WARN_SUBSTR 27 +#endif + +#ifndef WARN_SYNTAX +# define WARN_SYNTAX 28 +#endif + +#ifndef WARN_AMBIGUOUS +# define WARN_AMBIGUOUS 29 +#endif + +#ifndef WARN_BAREWORD +# define WARN_BAREWORD 30 +#endif + +#ifndef WARN_DIGIT +# define WARN_DIGIT 31 +#endif + +#ifndef WARN_PARENTHESIS +# define WARN_PARENTHESIS 32 +#endif + +#ifndef WARN_PRECEDENCE +# define WARN_PRECEDENCE 33 +#endif + +#ifndef WARN_PRINTF +# define WARN_PRINTF 34 +#endif + +#ifndef WARN_PROTOTYPE +# define WARN_PROTOTYPE 35 +#endif + +#ifndef WARN_QW +# define WARN_QW 36 +#endif + +#ifndef WARN_RESERVED +# define WARN_RESERVED 37 +#endif + +#ifndef WARN_SEMICOLON +# define WARN_SEMICOLON 38 +#endif + +#ifndef WARN_TAINT +# define WARN_TAINT 39 +#endif + +#ifndef WARN_THREADS +# define WARN_THREADS 40 +#endif + +#ifndef WARN_UNINITIALIZED +# define WARN_UNINITIALIZED 41 +#endif + +#ifndef WARN_UNPACK +# define WARN_UNPACK 42 +#endif + +#ifndef WARN_UNTIE +# define WARN_UNTIE 43 +#endif + +#ifndef WARN_UTF8 +# define WARN_UTF8 44 +#endif + +#ifndef WARN_VOID +# define WARN_VOID 45 +#endif + +#ifndef WARN_ASSERTIONS +# define WARN_ASSERTIONS 46 +#endif +#ifndef packWARN +# define packWARN(a) (a) +#endif + +#ifndef ckWARN +# ifdef G_WARN_ON +# define ckWARN(a) (PL_dowarn & G_WARN_ON) +# else +# define ckWARN(a) PL_dowarn +# endif +#endif + +#if (PERL_BCDVERSION >= 0x5004000) && !defined(warner) +#if defined(NEED_warner) +static void DPPP_(my_warner)(U32 err, const char *pat, ...); +static +#else +extern void DPPP_(my_warner)(U32 err, const char *pat, ...); +#endif + +#define Perl_warner DPPP_(my_warner) + +#if defined(NEED_warner) || defined(NEED_warner_GLOBAL) + +void +DPPP_(my_warner)(U32 err, const char *pat, ...) +{ + SV *sv; + va_list args; + + PERL_UNUSED_ARG(err); + + va_start(args, pat); + sv = vnewSVpvf(pat, &args); + va_end(args); + sv_2mortal(sv); + warn("%s", SvPV_nolen(sv)); +} + +#define warner Perl_warner + +#define Perl_warner_nocontext Perl_warner + +#endif +#endif + +/* concatenating with "" ensures that only literal strings are accepted as argument + * note that STR_WITH_LEN() can't be used as argument to macros or functions that + * under some configurations might be macros + */ +#ifndef STR_WITH_LEN +# define STR_WITH_LEN(s) (s ""), (sizeof(s)-1) +#endif +#ifndef newSVpvs +# define newSVpvs(str) newSVpvn(str "", sizeof(str) - 1) +#endif + +#ifndef newSVpvs_flags +# define newSVpvs_flags(str, flags) newSVpvn_flags(str "", sizeof(str) - 1, flags) +#endif + +#ifndef sv_catpvs +# define sv_catpvs(sv, str) sv_catpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef sv_setpvs +# define sv_setpvs(sv, str) sv_setpvn(sv, str "", sizeof(str) - 1) +#endif + +#ifndef hv_fetchs +# define hv_fetchs(hv, key, lval) hv_fetch(hv, key "", sizeof(key) - 1, lval) +#endif + +#ifndef hv_stores +# define hv_stores(hv, key, val) hv_store(hv, key "", sizeof(key) - 1, val, 0) +#endif +#ifndef gv_fetchpvn_flags +# define gv_fetchpvn_flags(name, len, flags, svt) gv_fetchpv(name, flags, svt) +#endif + +#ifndef gv_fetchpvs +# define gv_fetchpvs(name, flags, svt) gv_fetchpvn_flags(name "", sizeof(name) - 1, flags, svt) +#endif + +#ifndef gv_stashpvs +# define gv_stashpvs(name, flags) gv_stashpvn(name "", sizeof(name) - 1, flags) +#endif +#ifndef SvGETMAGIC +# define SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END +#endif +#ifndef PERL_MAGIC_sv +# define PERL_MAGIC_sv '\0' +#endif + +#ifndef PERL_MAGIC_overload +# define PERL_MAGIC_overload 'A' +#endif + +#ifndef PERL_MAGIC_overload_elem +# define PERL_MAGIC_overload_elem 'a' +#endif + +#ifndef PERL_MAGIC_overload_table +# define PERL_MAGIC_overload_table 'c' +#endif + +#ifndef PERL_MAGIC_bm +# define PERL_MAGIC_bm 'B' +#endif + +#ifndef PERL_MAGIC_regdata +# define PERL_MAGIC_regdata 'D' +#endif + +#ifndef PERL_MAGIC_regdatum +# define PERL_MAGIC_regdatum 'd' +#endif + +#ifndef PERL_MAGIC_env +# define PERL_MAGIC_env 'E' +#endif + +#ifndef PERL_MAGIC_envelem +# define PERL_MAGIC_envelem 'e' +#endif + +#ifndef PERL_MAGIC_fm +# define PERL_MAGIC_fm 'f' +#endif + +#ifndef PERL_MAGIC_regex_global +# define PERL_MAGIC_regex_global 'g' +#endif + +#ifndef PERL_MAGIC_isa +# define PERL_MAGIC_isa 'I' +#endif + +#ifndef PERL_MAGIC_isaelem +# define PERL_MAGIC_isaelem 'i' +#endif + +#ifndef PERL_MAGIC_nkeys +# define PERL_MAGIC_nkeys 'k' +#endif + +#ifndef PERL_MAGIC_dbfile +# define PERL_MAGIC_dbfile 'L' +#endif + +#ifndef PERL_MAGIC_dbline +# define PERL_MAGIC_dbline 'l' +#endif + +#ifndef PERL_MAGIC_mutex +# define PERL_MAGIC_mutex 'm' +#endif + +#ifndef PERL_MAGIC_shared +# define PERL_MAGIC_shared 'N' +#endif + +#ifndef PERL_MAGIC_shared_scalar +# define PERL_MAGIC_shared_scalar 'n' +#endif + +#ifndef PERL_MAGIC_collxfrm +# define PERL_MAGIC_collxfrm 'o' +#endif + +#ifndef PERL_MAGIC_tied +# define PERL_MAGIC_tied 'P' +#endif + +#ifndef PERL_MAGIC_tiedelem +# define PERL_MAGIC_tiedelem 'p' +#endif + +#ifndef PERL_MAGIC_tiedscalar +# define PERL_MAGIC_tiedscalar 'q' +#endif + +#ifndef PERL_MAGIC_qr +# define PERL_MAGIC_qr 'r' +#endif + +#ifndef PERL_MAGIC_sig +# define PERL_MAGIC_sig 'S' +#endif + +#ifndef PERL_MAGIC_sigelem +# define PERL_MAGIC_sigelem 's' +#endif + +#ifndef PERL_MAGIC_taint +# define PERL_MAGIC_taint 't' +#endif + +#ifndef PERL_MAGIC_uvar +# define PERL_MAGIC_uvar 'U' +#endif + +#ifndef PERL_MAGIC_uvar_elem +# define PERL_MAGIC_uvar_elem 'u' +#endif + +#ifndef PERL_MAGIC_vstring +# define PERL_MAGIC_vstring 'V' +#endif + +#ifndef PERL_MAGIC_vec +# define PERL_MAGIC_vec 'v' +#endif + +#ifndef PERL_MAGIC_utf8 +# define PERL_MAGIC_utf8 'w' +#endif + +#ifndef PERL_MAGIC_substr +# define PERL_MAGIC_substr 'x' +#endif + +#ifndef PERL_MAGIC_defelem +# define PERL_MAGIC_defelem 'y' +#endif + +#ifndef PERL_MAGIC_glob +# define PERL_MAGIC_glob '*' +#endif + +#ifndef PERL_MAGIC_arylen +# define PERL_MAGIC_arylen '#' +#endif + +#ifndef PERL_MAGIC_pos +# define PERL_MAGIC_pos '.' +#endif + +#ifndef PERL_MAGIC_backref +# define PERL_MAGIC_backref '<' +#endif + +#ifndef PERL_MAGIC_ext +# define PERL_MAGIC_ext '~' +#endif + +/* That's the best we can do... */ +#ifndef sv_catpvn_nomg +# define sv_catpvn_nomg sv_catpvn +#endif + +#ifndef sv_catsv_nomg +# define sv_catsv_nomg sv_catsv +#endif + +#ifndef sv_setsv_nomg +# define sv_setsv_nomg sv_setsv +#endif + +#ifndef sv_pvn_nomg +# define sv_pvn_nomg sv_pvn +#endif + +#ifndef SvIV_nomg +# define SvIV_nomg SvIV +#endif + +#ifndef SvUV_nomg +# define SvUV_nomg SvUV +#endif + +#ifndef sv_catpv_mg +# define sv_catpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catpvn_mg +# define sv_catpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_catpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_catsv_mg +# define sv_catsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_catsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setiv_mg +# define sv_setiv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setiv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setnv_mg +# define sv_setnv_mg(sv, num) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setnv(TeMpSv,num); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpv_mg +# define sv_setpv_mg(sv, ptr) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpv(TeMpSv,ptr); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setpvn_mg +# define sv_setpvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setpvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setsv_mg +# define sv_setsv_mg(dsv, ssv) \ + STMT_START { \ + SV *TeMpSv = dsv; \ + sv_setsv(TeMpSv,ssv); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_setuv_mg +# define sv_setuv_mg(sv, i) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_setuv(TeMpSv,i); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif + +#ifndef sv_usepvn_mg +# define sv_usepvn_mg(sv, ptr, len) \ + STMT_START { \ + SV *TeMpSv = sv; \ + sv_usepvn(TeMpSv,ptr,len); \ + SvSETMAGIC(TeMpSv); \ + } STMT_END +#endif +#ifndef SvVSTRING_mg +# define SvVSTRING_mg(sv) (SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_vstring) : NULL) +#endif + +/* Hint: sv_magic_portable + * This is a compatibility function that is only available with + * Devel::PPPort. It is NOT in the perl core. + * Its purpose is to mimic the 5.8.0 behaviour of sv_magic() when + * it is being passed a name pointer with namlen == 0. In that + * case, perl 5.8.0 and later store the pointer, not a copy of it. + * The compatibility can be provided back to perl 5.004. With + * earlier versions, the code will not compile. + */ + +#if (PERL_BCDVERSION < 0x5004000) + + /* code that uses sv_magic_portable will not compile */ + +#elif (PERL_BCDVERSION < 0x5008000) + +# define sv_magic_portable(sv, obj, how, name, namlen) \ + STMT_START { \ + SV *SvMp_sv = (sv); \ + char *SvMp_name = (char *) (name); \ + I32 SvMp_namlen = (namlen); \ + if (SvMp_name && SvMp_namlen == 0) \ + { \ + MAGIC *mg; \ + sv_magic(SvMp_sv, obj, how, 0, 0); \ + mg = SvMAGIC(SvMp_sv); \ + mg->mg_len = -42; /* XXX: this is the tricky part */ \ + mg->mg_ptr = SvMp_name; \ + } \ + else \ + { \ + sv_magic(SvMp_sv, obj, how, SvMp_name, SvMp_namlen); \ + } \ + } STMT_END + +#else + +# define sv_magic_portable(a, b, c, d, e) sv_magic(a, b, c, d, e) + +#endif + +#ifdef USE_ITHREADS +#ifndef CopFILE +# define CopFILE(c) ((c)->cop_file) +#endif + +#ifndef CopFILEGV +# define CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) ((c)->cop_file = savepv(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) ((c)->cop_stashpv) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch)) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) +#endif + +#else +#ifndef CopFILEGV +# define CopFILEGV(c) ((c)->cop_filegv) +#endif + +#ifndef CopFILEGV_set +# define CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv)) +#endif + +#ifndef CopFILE_set +# define CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv)) +#endif + +#ifndef CopFILESV +# define CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv) +#endif + +#ifndef CopFILEAV +# define CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav) +#endif + +#ifndef CopFILE +# define CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch) +#endif + +#ifndef CopSTASH +# define CopSTASH(c) ((c)->cop_stash) +#endif + +#ifndef CopSTASH_set +# define CopSTASH_set(c,hv) ((c)->cop_stash = (hv)) +#endif + +#ifndef CopSTASHPV +# define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) +#endif + +#ifndef CopSTASHPV_set +# define CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD)) +#endif + +#ifndef CopSTASH_eq +# define CopSTASH_eq(c,hv) (CopSTASH(c) == (hv)) +#endif + +#endif /* USE_ITHREADS */ +#ifndef IN_PERL_COMPILETIME +# define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling) +#endif + +#ifndef IN_LOCALE_RUNTIME +# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE_COMPILETIME +# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE) +#endif + +#ifndef IN_LOCALE +# define IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME) +#endif +#ifndef IS_NUMBER_IN_UV +# define IS_NUMBER_IN_UV 0x01 +#endif + +#ifndef IS_NUMBER_GREATER_THAN_UV_MAX +# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef IS_NUMBER_NOT_INT +# define IS_NUMBER_NOT_INT 0x04 +#endif + +#ifndef IS_NUMBER_NEG +# define IS_NUMBER_NEG 0x08 +#endif + +#ifndef IS_NUMBER_INFINITY +# define IS_NUMBER_INFINITY 0x10 +#endif + +#ifndef IS_NUMBER_NAN +# define IS_NUMBER_NAN 0x20 +#endif +#ifndef GROK_NUMERIC_RADIX +# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send) +#endif +#ifndef PERL_SCAN_GREATER_THAN_UV_MAX +# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02 +#endif + +#ifndef PERL_SCAN_SILENT_ILLDIGIT +# define PERL_SCAN_SILENT_ILLDIGIT 0x04 +#endif + +#ifndef PERL_SCAN_ALLOW_UNDERSCORES +# define PERL_SCAN_ALLOW_UNDERSCORES 0x01 +#endif + +#ifndef PERL_SCAN_DISALLOW_PREFIX +# define PERL_SCAN_DISALLOW_PREFIX 0x02 +#endif + +#ifndef grok_numeric_radix +#if defined(NEED_grok_numeric_radix) +static bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +static +#else +extern bool DPPP_(my_grok_numeric_radix)(pTHX_ const char ** sp, const char * send); +#endif + +#ifdef grok_numeric_radix +# undef grok_numeric_radix +#endif +#define grok_numeric_radix(a,b) DPPP_(my_grok_numeric_radix)(aTHX_ a,b) +#define Perl_grok_numeric_radix DPPP_(my_grok_numeric_radix) + +#if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) +bool +DPPP_(my_grok_numeric_radix)(pTHX_ const char **sp, const char *send) +{ +#ifdef USE_LOCALE_NUMERIC +#ifdef PL_numeric_radix_sv + if (PL_numeric_radix_sv && IN_LOCALE) { + STRLEN len; + char* radix = SvPV(PL_numeric_radix_sv, len); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#else + /* older perls don't have PL_numeric_radix_sv so the radix + * must manually be requested from locale.h + */ +#include <locale.h> + dTHR; /* needed for older threaded perls */ + struct lconv *lc = localeconv(); + char *radix = lc->decimal_point; + if (radix && IN_LOCALE) { + STRLEN len = strlen(radix); + if (*sp + len <= send && memEQ(*sp, radix, len)) { + *sp += len; + return TRUE; + } + } +#endif +#endif /* USE_LOCALE_NUMERIC */ + /* always try "." if numeric radix didn't match because + * we may have data from different locales mixed */ + if (*sp < send && **sp == '.') { + ++*sp; + return TRUE; + } + return FALSE; +} +#endif +#endif + +#ifndef grok_number +#if defined(NEED_grok_number) +static int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +static +#else +extern int DPPP_(my_grok_number)(pTHX_ const char * pv, STRLEN len, UV * valuep); +#endif + +#ifdef grok_number +# undef grok_number +#endif +#define grok_number(a,b,c) DPPP_(my_grok_number)(aTHX_ a,b,c) +#define Perl_grok_number DPPP_(my_grok_number) + +#if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) +int +DPPP_(my_grok_number)(pTHX_ const char *pv, STRLEN len, UV *valuep) +{ + const char *s = pv; + const char *send = pv + len; + const UV max_div_10 = UV_MAX / 10; + const char max_mod_10 = UV_MAX % 10; + int numtype = 0; + int sawinf = 0; + int sawnan = 0; + + while (s < send && isSPACE(*s)) + s++; + if (s == send) { + return 0; + } else if (*s == '-') { + s++; + numtype = IS_NUMBER_NEG; + } + else if (*s == '+') + s++; + + if (s == send) + return 0; + + /* next must be digit or the radix separator or beginning of infinity */ + if (isDIGIT(*s)) { + /* UVs are at least 32 bits, so the first 9 decimal digits cannot + overflow. */ + UV value = *s - '0'; + /* This construction seems to be more optimizer friendly. + (without it gcc does the isDIGIT test and the *s - '0' separately) + With it gcc on arm is managing 6 instructions (6 cycles) per digit. + In theory the optimizer could deduce how far to unroll the loop + before checking for overflow. */ + if (++s < send) { + int digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + digit = *s - '0'; + if (digit >= 0 && digit <= 9) { + value = value * 10 + digit; + if (++s < send) { + /* Now got 9 digits, so need to check + each time for overflow. */ + digit = *s - '0'; + while (digit >= 0 && digit <= 9 + && (value < max_div_10 + || (value == max_div_10 + && digit <= max_mod_10))) { + value = value * 10 + digit; + if (++s < send) + digit = *s - '0'; + else + break; + } + if (digit >= 0 && digit <= 9 + && (s < send)) { + /* value overflowed. + skip the remaining digits, don't + worry about setting *valuep. */ + do { + s++; + } while (s < send && isDIGIT(*s)); + numtype |= + IS_NUMBER_GREATER_THAN_UV_MAX; + goto skip_value; + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + } + numtype |= IS_NUMBER_IN_UV; + if (valuep) + *valuep = value; + + skip_value: + if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT; + while (s < send && isDIGIT(*s)) /* optional digits after the radix */ + s++; + } + } + else if (GROK_NUMERIC_RADIX(&s, send)) { + numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */ + /* no digits before the radix means we need digits after it */ + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + if (valuep) { + /* integer approximation is valid - it's 0. */ + *valuep = 0; + } + } + else + return 0; + } else if (*s == 'I' || *s == 'i') { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'F' && *s != 'f')) return 0; + s++; if (s < send && (*s == 'I' || *s == 'i')) { + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; if (s == send || (*s != 'I' && *s != 'i')) return 0; + s++; if (s == send || (*s != 'T' && *s != 't')) return 0; + s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0; + s++; + } + sawinf = 1; + } else if (*s == 'N' || *s == 'n') { + /* XXX TODO: There are signaling NaNs and quiet NaNs. */ + s++; if (s == send || (*s != 'A' && *s != 'a')) return 0; + s++; if (s == send || (*s != 'N' && *s != 'n')) return 0; + s++; + sawnan = 1; + } else + return 0; + + if (sawinf) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; + } else if (sawnan) { + numtype &= IS_NUMBER_NEG; /* Keep track of sign */ + numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT; + } else if (s < send) { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + /* The only flag we keep is sign. Blow away any "it's UV" */ + numtype &= IS_NUMBER_NEG; + numtype |= IS_NUMBER_NOT_INT; + s++; + if (s < send && (*s == '-' || *s == '+')) + s++; + if (s < send && isDIGIT(*s)) { + do { + s++; + } while (s < send && isDIGIT(*s)); + } + else + return 0; + } + } + while (s < send && isSPACE(*s)) + s++; + if (s >= send) + return numtype; + if (len == 10 && memEQ(pv, "0 but true", 10)) { + if (valuep) + *valuep = 0; + return IS_NUMBER_IN_UV; + } + return 0; +} +#endif +#endif + +/* + * The grok_* routines have been modified to use warn() instead of + * Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit, + * which is why the stack variable has been renamed to 'xdigit'. + */ + +#ifndef grok_bin +#if defined(NEED_grok_bin) +static UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_bin)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_bin +# undef grok_bin +#endif +#define grok_bin(a,b,c,d) DPPP_(my_grok_bin)(aTHX_ a,b,c,d) +#define Perl_grok_bin DPPP_(my_grok_bin) + +#if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) +UV +DPPP_(my_grok_bin)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_2 = UV_MAX / 2; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading b or 0b. + for compatibility silently suffer "b" and "0b" as valid binary + numbers. */ + if (len >= 1) { + if (s[0] == 'b') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'b') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + char bit = *s; + if (bit == '0' || bit == '1') { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_bin. */ + redo: + if (!overflowed) { + if (value <= max_div_2) { + value = (value << 1) | (bit - '0'); + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in binary number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 2.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount. */ + value_nv += (NV)(bit - '0'); + continue; + } + if (bit == '_' && len && allow_underscores && (bit = s[1]) + && (bit == '0' || bit == '1')) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal binary digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Binary number > 0b11111111111111111111111111111111 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_hex +#if defined(NEED_grok_hex) +static UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_hex)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_hex +# undef grok_hex +#endif +#define grok_hex(a,b,c,d) DPPP_(my_grok_hex)(aTHX_ a,b,c,d) +#define Perl_grok_hex DPPP_(my_grok_hex) + +#if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) +UV +DPPP_(my_grok_hex)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_16 = UV_MAX / 16; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + const char *xdigit; + + if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) { + /* strip off leading x or 0x. + for compatibility silently suffer "x" and "0x" as valid hex numbers. + */ + if (len >= 1) { + if (s[0] == 'x') { + s++; + len--; + } + else if (len >= 2 && s[0] == '0' && s[1] == 'x') { + s+=2; + len-=2; + } + } + } + + for (; len-- && *s; s++) { + xdigit = strchr((char *) PL_hexdigit, *s); + if (xdigit) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + With gcc seems to be much straighter code than old scan_hex. */ + redo: + if (!overflowed) { + if (value <= max_div_16) { + value = (value << 4) | ((xdigit - PL_hexdigit) & 15); + continue; + } + warn("Integer overflow in hexadecimal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 16.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 16-tuples. */ + value_nv += (NV)((xdigit - PL_hexdigit) & 15); + continue; + } + if (*s == '_' && len && allow_underscores && s[1] + && (xdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + goto redo; + } + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal hexadecimal digit '%c' ignored", *s); + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Hexadecimal number > 0xffffffff non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#ifndef grok_oct +#if defined(NEED_grok_oct) +static UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +static +#else +extern UV DPPP_(my_grok_oct)(pTHX_ const char * start, STRLEN * len_p, I32 * flags, NV * result); +#endif + +#ifdef grok_oct +# undef grok_oct +#endif +#define grok_oct(a,b,c,d) DPPP_(my_grok_oct)(aTHX_ a,b,c,d) +#define Perl_grok_oct DPPP_(my_grok_oct) + +#if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) +UV +DPPP_(my_grok_oct)(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) +{ + const char *s = start; + STRLEN len = *len_p; + UV value = 0; + NV value_nv = 0; + + const UV max_div_8 = UV_MAX / 8; + bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES; + bool overflowed = FALSE; + + for (; len-- && *s; s++) { + /* gcc 2.95 optimizer not smart enough to figure that this subtraction + out front allows slicker code. */ + int digit = *s - '0'; + if (digit >= 0 && digit <= 7) { + /* Write it in this wonky order with a goto to attempt to get the + compiler to make the common case integer-only loop pretty tight. + */ + redo: + if (!overflowed) { + if (value <= max_div_8) { + value = (value << 3) | digit; + continue; + } + /* Bah. We're just overflowed. */ + warn("Integer overflow in octal number"); + overflowed = TRUE; + value_nv = (NV) value; + } + value_nv *= 8.0; + /* If an NV has not enough bits in its mantissa to + * represent a UV this summing of small low-order numbers + * is a waste of time (because the NV cannot preserve + * the low-order bits anyway): we could just remember when + * did we overflow and in the end just multiply value_nv by the + * right amount of 8-tuples. */ + value_nv += (NV)digit; + continue; + } + if (digit == ('_' - '0') && len && allow_underscores + && (digit = s[1] - '0') && (digit >= 0 && digit <= 7)) + { + --len; + ++s; + goto redo; + } + /* Allow \octal to work the DWIM way (that is, stop scanning + * as soon as non-octal characters are seen, complain only iff + * someone seems to want to use the digits eight and nine). */ + if (digit == 8 || digit == 9) { + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + warn("Illegal octal digit '%c' ignored", *s); + } + break; + } + + if ( ( overflowed && value_nv > 4294967295.0) +#if UVSIZE > 4 + || (!overflowed && value > 0xffffffff ) +#endif + ) { + warn("Octal number > 037777777777 non-portable"); + } + *len_p = s - start; + if (!overflowed) { + *flags = 0; + return value; + } + *flags = PERL_SCAN_GREATER_THAN_UV_MAX; + if (result) + *result = value_nv; + return UV_MAX; +} +#endif +#endif + +#if !defined(my_snprintf) +#if defined(NEED_my_snprintf) +static int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +static +#else +extern int DPPP_(my_my_snprintf)(char * buffer, const Size_t len, const char * format, ...); +#endif + +#define my_snprintf DPPP_(my_my_snprintf) +#define Perl_my_snprintf DPPP_(my_my_snprintf) + +#if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) + +int +DPPP_(my_my_snprintf)(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +#endif +#endif + +#if !defined(my_sprintf) +#if defined(NEED_my_sprintf) +static int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +static +#else +extern int DPPP_(my_my_sprintf)(char * buffer, const char * pat, ...); +#endif + +#define my_sprintf DPPP_(my_my_sprintf) +#define Perl_my_sprintf DPPP_(my_my_sprintf) + +#if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) + +int +DPPP_(my_my_sprintf)(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} + +#endif +#endif + +#ifdef NO_XSLOCKS +# ifdef dJMPENV +# define dXCPT dJMPENV; int rEtV = 0 +# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0) +# define XCPT_TRY_END JMPENV_POP; +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW JMPENV_JUMP(rEtV) +# else +# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0 +# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0) +# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf); +# define XCPT_CATCH if (rEtV != 0) +# define XCPT_RETHROW Siglongjmp(top_env, rEtV) +# endif +#endif + +#if !defined(my_strlcat) +#if defined(NEED_my_strlcat) +static Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcat)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcat DPPP_(my_my_strlcat) +#define Perl_my_strlcat DPPP_(my_my_strlcat) + +#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) + +Size_t +DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif +#endif + +#if !defined(my_strlcpy) +#if defined(NEED_my_strlcpy) +static Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +static +#else +extern Size_t DPPP_(my_my_strlcpy)(char * dst, const char * src, Size_t size); +#endif + +#define my_strlcpy DPPP_(my_my_strlcpy) +#define Perl_my_strlcpy DPPP_(my_my_strlcpy) + +#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) + +Size_t +DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} + +#endif +#endif +#ifndef PERL_PV_ESCAPE_QUOTE +# define PERL_PV_ESCAPE_QUOTE 0x0001 +#endif + +#ifndef PERL_PV_PRETTY_QUOTE +# define PERL_PV_PRETTY_QUOTE PERL_PV_ESCAPE_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_ELLIPSES +# define PERL_PV_PRETTY_ELLIPSES 0x0002 +#endif + +#ifndef PERL_PV_PRETTY_LTGT +# define PERL_PV_PRETTY_LTGT 0x0004 +#endif + +#ifndef PERL_PV_ESCAPE_FIRSTCHAR +# define PERL_PV_ESCAPE_FIRSTCHAR 0x0008 +#endif + +#ifndef PERL_PV_ESCAPE_UNI +# define PERL_PV_ESCAPE_UNI 0x0100 +#endif + +#ifndef PERL_PV_ESCAPE_UNI_DETECT +# define PERL_PV_ESCAPE_UNI_DETECT 0x0200 +#endif + +#ifndef PERL_PV_ESCAPE_ALL +# define PERL_PV_ESCAPE_ALL 0x1000 +#endif + +#ifndef PERL_PV_ESCAPE_NOBACKSLASH +# define PERL_PV_ESCAPE_NOBACKSLASH 0x2000 +#endif + +#ifndef PERL_PV_ESCAPE_NOCLEAR +# define PERL_PV_ESCAPE_NOCLEAR 0x4000 +#endif + +#ifndef PERL_PV_ESCAPE_RE +# define PERL_PV_ESCAPE_RE 0x8000 +#endif + +#ifndef PERL_PV_PRETTY_NOCLEAR +# define PERL_PV_PRETTY_NOCLEAR PERL_PV_ESCAPE_NOCLEAR +#endif +#ifndef PERL_PV_PRETTY_DUMP +# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE +#endif + +#ifndef PERL_PV_PRETTY_REGPROP +# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE +#endif + +/* Hint: pv_escape + * Note that unicode functionality is only backported to + * those perl versions that support it. For older perl + * versions, the implementation will fall back to bytes. + */ + +#ifndef pv_escape +#if defined(NEED_pv_escape) +static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +static +#else +extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags); +#endif + +#ifdef pv_escape +# undef pv_escape +#endif +#define pv_escape(a,b,c,d,e,f) DPPP_(my_pv_escape)(aTHX_ a,b,c,d,e,f) +#define Perl_pv_escape DPPP_(my_pv_escape) + +#if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) + +char * +DPPP_(my_pv_escape)(pTHX_ SV *dsv, char const * const str, + const STRLEN count, const STRLEN max, + STRLEN * const escaped, const U32 flags) +{ + const char esc = flags & PERL_PV_ESCAPE_RE ? '%' : '\\'; + const char dq = flags & PERL_PV_ESCAPE_QUOTE ? '"' : esc; + char octbuf[32] = "%123456789ABCDF"; + STRLEN wrote = 0; + STRLEN chsize = 0; + STRLEN readsize = 1; +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + bool isuni = flags & PERL_PV_ESCAPE_UNI ? 1 : 0; +#endif + const char *pv = str; + const char * const end = pv + count; + octbuf[0] = esc; + + if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) + sv_setpvs(dsv, ""); + +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) + isuni = 1; +#endif + + for (; pv < end && (!max || wrote < max) ; pv += readsize) { + const UV u = +#if defined(is_utf8_string) && defined(utf8_to_uvchr) + isuni ? utf8_to_uvchr((U8*)pv, &readsize) : +#endif + (U8)*pv; + const U8 c = (U8)u & 0xFF; + + if (u > 255 || (flags & PERL_PV_ESCAPE_ALL)) { + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + chsize = my_snprintf(octbuf, sizeof octbuf, + "%"UVxf, u); + else + chsize = my_snprintf(octbuf, sizeof octbuf, + "%cx{%"UVxf"}", esc, u); + } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { + chsize = 1; + } else { + if (c == dq || c == esc || !isPRINT(c)) { + chsize = 2; + switch (c) { + case '\\' : /* fallthrough */ + case '%' : if (c == esc) + octbuf[1] = esc; + else + chsize = 1; + break; + case '\v' : octbuf[1] = 'v'; break; + case '\t' : octbuf[1] = 't'; break; + case '\r' : octbuf[1] = 'r'; break; + case '\n' : octbuf[1] = 'n'; break; + case '\f' : octbuf[1] = 'f'; break; + case '"' : if (dq == '"') + octbuf[1] = '"'; + else + chsize = 1; + break; + default: chsize = my_snprintf(octbuf, sizeof octbuf, + pv < end && isDIGIT((U8)*(pv+readsize)) + ? "%c%03o" : "%c%o", esc, c); + } + } else { + chsize = 1; + } + } + if (max && wrote + chsize > max) { + break; + } else if (chsize > 1) { + sv_catpvn(dsv, octbuf, chsize); + wrote += chsize; + } else { + char tmp[2]; + my_snprintf(tmp, sizeof tmp, "%c", c); + sv_catpvn(dsv, tmp, 1); + wrote++; + } + if (flags & PERL_PV_ESCAPE_FIRSTCHAR) + break; + } + if (escaped != NULL) + *escaped= pv - str; + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_pretty +#if defined(NEED_pv_pretty) +static char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +static +#else +extern char * DPPP_(my_pv_pretty)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, char const * const start_color, char const * const end_color, const U32 flags); +#endif + +#ifdef pv_pretty +# undef pv_pretty +#endif +#define pv_pretty(a,b,c,d,e,f,g) DPPP_(my_pv_pretty)(aTHX_ a,b,c,d,e,f,g) +#define Perl_pv_pretty DPPP_(my_pv_pretty) + +#if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) + +char * +DPPP_(my_pv_pretty)(pTHX_ SV *dsv, char const * const str, const STRLEN count, + const STRLEN max, char const * const start_color, char const * const end_color, + const U32 flags) +{ + const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; + STRLEN escaped; + + if (!(flags & PERL_PV_PRETTY_NOCLEAR)) + sv_setpvs(dsv, ""); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, "<"); + + if (start_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(start_color)); + + pv_escape(dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR); + + if (end_color != NULL) + sv_catpv(dsv, D_PPP_CONSTPV_ARG(end_color)); + + if (dq == '"') + sv_catpvs(dsv, "\""); + else if (flags & PERL_PV_PRETTY_LTGT) + sv_catpvs(dsv, ">"); + + if ((flags & PERL_PV_PRETTY_ELLIPSES) && escaped < count) + sv_catpvs(dsv, "..."); + + return SvPVX(dsv); +} + +#endif +#endif + +#ifndef pv_display +#if defined(NEED_pv_display) +static char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +static +#else +extern char * DPPP_(my_pv_display)(pTHX_ SV * dsv, const char * pv, STRLEN cur, STRLEN len, STRLEN pvlim); +#endif + +#ifdef pv_display +# undef pv_display +#endif +#define pv_display(a,b,c,d,e) DPPP_(my_pv_display)(aTHX_ a,b,c,d,e) +#define Perl_pv_display DPPP_(my_pv_display) + +#if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) + +char * +DPPP_(my_pv_display)(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) +{ + pv_pretty(dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); + if (len > cur && pv[cur] == '\0') + sv_catpvs(dsv, "\\0"); + return SvPVX(dsv); +} + +#endif +#endif + +#endif /* _P_P_PORTABILITY_H_ */ + +/* End of File ppport.h */ diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql new file mode 100644 index 0000000..b0d950b --- /dev/null +++ b/src/pl/plperl/sql/plperl.sql @@ -0,0 +1,523 @@ +-- +-- Test result value processing +-- + +CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ +return undef; +$$ LANGUAGE plperl; + +SELECT perl_int(11); +SELECT * FROM perl_int(42); + +CREATE OR REPLACE FUNCTION perl_int(int) RETURNS INTEGER AS $$ +return $_[0] + 1; +$$ LANGUAGE plperl; + +SELECT perl_int(11); +SELECT * FROM perl_int(42); + + +CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ +return undef; +$$ LANGUAGE plperl; + +SELECT perl_set_int(5); +SELECT * FROM perl_set_int(5); + +CREATE OR REPLACE FUNCTION perl_set_int(int) RETURNS SETOF INTEGER AS $$ +return [0..$_[0]]; +$$ LANGUAGE plperl; + +SELECT perl_set_int(5); +SELECT * FROM perl_set_int(5); + + +CREATE TYPE testnestperl AS (f5 integer[]); +CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl); + +CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ + return undef; +$$ LANGUAGE plperl; + +SELECT perl_row(); +SELECT * FROM perl_row(); + + +CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } }; +$$ LANGUAGE plperl; + +SELECT perl_row(); +SELECT * FROM perl_row(); + +-- test returning a composite literal +CREATE OR REPLACE FUNCTION perl_row_lit() RETURNS testrowperl AS $$ + return '(1,hello,world,"({{1}})")'; +$$ LANGUAGE plperl; + +SELECT perl_row_lit(); + + +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return undef; +$$ LANGUAGE plperl; + +SELECT perl_set(); +SELECT * FROM perl_set(); + +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + undef, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} }, + { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }}, + { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }}, + { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }}, + ]; +$$ LANGUAGE plperl; + +SELECT perl_set(); +SELECT * FROM perl_set(); + +CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL', 'f4' => undef }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} }, + { f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }}, + { f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }}, + { f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }}, + { f1 => 7, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => '({1})' }, + ]; +$$ LANGUAGE plperl; + +SELECT perl_set(); +SELECT * FROM perl_set(); + +CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ + return undef; +$$ LANGUAGE plperl; + +SELECT perl_record(); +SELECT * FROM perl_record(); +SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); + +CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } }; +$$ LANGUAGE plperl; + +SELECT perl_record(); +SELECT * FROM perl_record(); +SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl); + + +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return undef; +$$ LANGUAGE plperl; + +SELECT perl_record_set(); +SELECT * FROM perl_record_set(); +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + undef, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; + +SELECT perl_record_set(); +SELECT * FROM perl_record_set(); +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + +CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; + +SELECT perl_record_set(); +SELECT * FROM perl_record_set(); +SELECT * FROM perl_record_set() AS (f1 integer, f2 text, f3 text); + +CREATE OR REPLACE FUNCTION +perl_out_params(f1 out integer, f2 out text, f3 out text) AS $$ + return {f2 => 'hello', f1 => 1, f3 => 'world'}; +$$ LANGUAGE plperl; + +SELECT perl_out_params(); +SELECT * FROM perl_out_params(); +SELECT (perl_out_params()).f2; + +CREATE OR REPLACE FUNCTION +perl_out_params_set(out f1 integer, out f2 text, out f3 text) +RETURNS SETOF record AS $$ + return [ + { f1 => 1, f2 => 'Hello', f3 => 'World' }, + { f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' }, + { f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' } + ]; +$$ LANGUAGE plperl; + +SELECT perl_out_params_set(); +SELECT * FROM perl_out_params_set(); +SELECT (perl_out_params_set()).f3; + +-- +-- Check behavior with erroneous return values +-- + +CREATE TYPE footype AS (x INTEGER, y INTEGER); + +CREATE OR REPLACE FUNCTION foo_good() RETURNS SETOF footype AS $$ +return [ + {x => 1, y => 2}, + {x => 3, y => 4} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_good(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return 42; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_bad() RETURNS footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return 42; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ + return {y => 3, z => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + [1, 2], + [3, 4] +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE OR REPLACE FUNCTION foo_set_bad() RETURNS SETOF footype AS $$ +return [ + {y => 3, z => 4} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_set_bad(); + +CREATE DOMAIN orderedfootype AS footype CHECK ((VALUE).x <= (VALUE).y); + +CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ + return {x => 3, y => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_ordered(); + +CREATE OR REPLACE FUNCTION foo_ordered() RETURNS orderedfootype AS $$ + return {x => 5, y => 4}; +$$ LANGUAGE plperl; + +SELECT * FROM foo_ordered(); -- fail + +CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ +return [ + {x => 3, y => 4}, + {x => 4, y => 7} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_ordered_set(); + +CREATE OR REPLACE FUNCTION foo_ordered_set() RETURNS SETOF orderedfootype AS $$ +return [ + {x => 3, y => 4}, + {x => 9, y => 7} +]; +$$ LANGUAGE plperl; + +SELECT * FROM foo_ordered_set(); -- fail + +-- +-- Check passing a tuple argument +-- + +CREATE OR REPLACE FUNCTION perl_get_field(footype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; + +SELECT perl_get_field((11,12), 'x'); +SELECT perl_get_field((11,12), 'y'); +SELECT perl_get_field((11,12), 'z'); + +CREATE OR REPLACE FUNCTION perl_get_cfield(orderedfootype, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; + +SELECT perl_get_cfield((11,12), 'x'); +SELECT perl_get_cfield((11,12), 'y'); +SELECT perl_get_cfield((12,11), 'x'); -- fail + +CREATE OR REPLACE FUNCTION perl_get_rfield(record, text) RETURNS integer AS $$ + return $_[0]->{$_[1]}; +$$ LANGUAGE plperl; + +SELECT perl_get_rfield((11,12), 'f1'); +SELECT perl_get_rfield((11,12)::footype, 'y'); +SELECT perl_get_rfield((11,12)::orderedfootype, 'x'); +SELECT perl_get_rfield((12,11)::orderedfootype, 'x'); -- fail + +-- +-- Test return_next +-- + +CREATE OR REPLACE FUNCTION perl_srf_rn() RETURNS SETOF RECORD AS $$ +my $i = 0; +for ("World", "PostgreSQL", "PL/Perl") { + return_next({f1=>++$i, f2=>'Hello', f3=>$_}); +} +return; +$$ language plperl; +SELECT * from perl_srf_rn() AS (f1 INTEGER, f2 TEXT, f3 TEXT); + +-- +-- Test spi_query/spi_fetchrow +-- + +CREATE OR REPLACE FUNCTION perl_spi_func() RETURNS SETOF INTEGER AS $$ +my $x = spi_query("select 1 as a union select 2 as a"); +while (defined (my $y = spi_fetchrow($x))) { + return_next($y->{a}); +} +return; +$$ LANGUAGE plperl; +SELECT * from perl_spi_func(); + +-- +-- Test spi_fetchrow abort +-- +CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$ +my $x = spi_query("select 1 as a union select 2 as a"); +spi_cursor_close( $x); +return 0; +$$ LANGUAGE plperl; +SELECT * from perl_spi_func2(); + + +--- +--- Test recursion via SPI +--- + + +CREATE OR REPLACE FUNCTION recurse(i int) RETURNS SETOF TEXT LANGUAGE plperl +AS $$ + + my $i = shift; + foreach my $x (1..$i) + { + return_next "hello $x"; + } + if ($i > 2) + { + my $z = $i-1; + my $cursor = spi_query("select * from recurse($z)"); + while (defined(my $row = spi_fetchrow($cursor))) + { + return_next "recurse $i: $row->{recurse}"; + } + } + return undef; + +$$; + +SELECT * FROM recurse(2); +SELECT * FROM recurse(3); + + +--- +--- Test array return +--- +CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][] +LANGUAGE plperl as $$ + return [['a"b',undef,'c,d'],['e\\f',undef,'g']]; +$$; + +SELECT array_of_text(); + +-- +-- Test spi_prepare/spi_exec_prepared/spi_freeplan +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$ + my $x = spi_prepare('select $1 AS a', 'INTEGER'); + my $q = spi_exec_prepared( $x, $_[0] + 1); + spi_freeplan($x); +return $q->{rows}->[0]->{a}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared(42); + +-- +-- Test spi_prepare/spi_query_prepared/spi_freeplan +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$ + my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4'); + my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]); + while (defined (my $y = spi_fetchrow($q))) { + return_next $y->{a}; + } + spi_freeplan($x); + return; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared_set(1,2); + +-- +-- Test prepare with a type with spaces +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_double(double precision) RETURNS double precision AS $$ + my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'DOUBLE PRECISION'); + my $q = spi_query_prepared($x,$_[0]); + my $result; + while (defined (my $y = spi_fetchrow($q))) { + $result = $y->{a}; + } + spi_freeplan($x); + return $result; +$$ LANGUAGE plperl; +SELECT perl_spi_prepared_double(4.35) as "double precision"; + +-- +-- Test with a bad type +-- +CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS double precision AS $$ + my $x = spi_prepare('SELECT 10.0 * $1 AS a', 'does_not_exist'); + my $q = spi_query_prepared($x,$_[0]); + my $result; + while (defined (my $y = spi_fetchrow($q))) { + $result = $y->{a}; + } + spi_freeplan($x); + return $result; +$$ LANGUAGE plperl; +SELECT perl_spi_prepared_bad(4.35) as "double precision"; + +-- Test with a row type +CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$ + my $x = spi_prepare('select $1::footype AS a', 'footype'); + my $q = spi_exec_prepared( $x, '(1, 2)'); + spi_freeplan($x); +return $q->{rows}->[0]->{a}->{x}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared(); + +CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$ + my $footype = shift; + my $x = spi_prepare('select $1 AS a', 'footype'); + my $q = spi_exec_prepared( $x, {}, $footype ); + spi_freeplan($x); +return $q->{rows}->[0]->{a}; +$$ LANGUAGE plperl; +SELECT * from perl_spi_prepared_row('(1, 2)'); + +-- simple test of a DO block +DO $$ + $a = 'This is a test'; + elog(NOTICE, $a); +$$ LANGUAGE plperl; + +-- check that restricted operations are rejected in a plperl DO block +DO $$ system("/nonesuch"); $$ LANGUAGE plperl; +DO $$ qx("/nonesuch"); $$ LANGUAGE plperl; +DO $$ open my $fh, "</nonesuch"; $$ LANGUAGE plperl; + +-- check that eval is allowed and eval'd restricted ops are caught +DO $$ eval q{chdir '.';}; warn "Caught: $@"; $$ LANGUAGE plperl; + +-- check that compiling do (dofile opcode) is allowed +-- but that executing it for a file not already loaded (via require) dies +DO $$ warn do "/dev/null"; $$ 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; + +-- check that we can "use warnings" (in this case to turn a warn into an error) +-- yields "ERROR: Useless use of sort in scalar context." +DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl; + +-- make sure functions marked as VOID without an explicit return work +CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$ + $_SHARED{myquote} = sub { + my $arg = shift; + $arg =~ s/(['\\])/\\$1/g; + return "'$arg'"; + }; +$$ LANGUAGE plperl; + +SELECT myfuncs(); + +-- make sure we can't return an array as a scalar +CREATE OR REPLACE FUNCTION text_arrayref() RETURNS text AS $$ + return ['array']; +$$ LANGUAGE plperl; + +SELECT text_arrayref(); + +--- make sure we can't return a hash as a scalar +CREATE OR REPLACE FUNCTION text_hashref() RETURNS text AS $$ + return {'hash'=>1}; +$$ LANGUAGE plperl; + +SELECT text_hashref(); + +---- make sure we can't return a blessed object as a scalar +CREATE OR REPLACE FUNCTION text_obj() RETURNS text AS $$ + return bless({}, 'Fake::Object'); +$$ LANGUAGE plperl; + +SELECT text_obj(); + +-- test looking through a scalar ref +CREATE OR REPLACE FUNCTION text_scalarref() RETURNS text AS $$ + my $str = 'str'; + return \$str; +$$ LANGUAGE plperl; + +SELECT text_scalarref(); + +-- check safe behavior when a function body is replaced during execution +CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS $$ + spi_exec_query('CREATE OR REPLACE FUNCTION self_modify(INTEGER) RETURNS INTEGER AS \'return $_[0] * 3;\' LANGUAGE plperl;'); + spi_exec_query('select self_modify(42) AS a'); + return $_[0] * 2; +$$ LANGUAGE plperl; + +SELECT self_modify(42); +SELECT self_modify(42); diff --git a/src/pl/plperl/sql/plperl_array.sql b/src/pl/plperl/sql/plperl_array.sql new file mode 100644 index 0000000..6617929 --- /dev/null +++ b/src/pl/plperl/sql/plperl_array.sql @@ -0,0 +1,171 @@ +CREATE OR REPLACE FUNCTION plperl_sum_array(INTEGER[]) RETURNS text AS $$ + my $array_arg = shift; + my $result = 0; + my @arrays; + + push @arrays, @$array_arg; + + while (@arrays > 0) { + my $el = shift @arrays; + if (is_array_ref($el)) { + push @arrays, @$el; + } else { + $result += $el; + } + } + return $result.' '.$array_arg; +$$ LANGUAGE plperl; + +select plperl_sum_array('{1,2,NULL}'); +select plperl_sum_array('{}'); +select plperl_sum_array('{{1,2,3}, {4,5,6}}'); +select plperl_sum_array('{{{1,2,3}, {4,5,6}}, {{7,8,9}, {10,11,12}}}'); + +-- check whether we can handle arrays of maximum dimension (6) +select plperl_sum_array(ARRAY[[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]], +[[13,14],[15,16]]]], +[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]], +[[[[[1,2],[3,4]],[[5,6],[7,8]]],[[[9,10],[11,12]],[[13,14],[15,16]]]], +[[[[17,18],[19,20]],[[21,22],[23,24]]],[[[25,26],[27,28]],[[29,30],[31,32]]]]]]); + +-- what would we do with the arrays exceeding maximum dimension (7) +select plperl_sum_array('{{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}}, +{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}, +{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}, +{{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}, +{{{{{1,2},{3,4}},{{5,6},{7,8}}},{{{9,10},{11,12}},{{13,14},{15,16}}}}, +{{{{17,18},{19,20}},{{21,22},{23,24}}},{{{25,26},{27,28}},{{29,30},{31,32}}}}}}}' +); + +select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {10, 11, 12}}}'); + +CREATE OR REPLACE FUNCTION plperl_concat(TEXT[]) RETURNS TEXT AS $$ + my $array_arg = shift; + my $result = ""; + my @arrays; + + push @arrays, @$array_arg; + while (@arrays > 0) { + my $el = shift @arrays; + if (is_array_ref($el)) { + push @arrays, @$el; + } else { + $result .= $el; + } + } + return $result.' '.$array_arg; +$$ LANGUAGE plperl; + +select plperl_concat('{"NULL","NULL","NULL''"}'); +select plperl_concat('{{NULL,NULL,NULL}}'); +select plperl_concat('{"hello"," ","world!"}'); + +-- array of rows -- +CREATE TYPE foo AS (bar INTEGER, baz TEXT); +CREATE OR REPLACE FUNCTION plperl_array_of_rows(foo[]) RETURNS TEXT AS $$ + my $array_arg = shift; + my $result = ""; + + for my $row_ref (@$array_arg) { + die "not a hash reference" unless (ref $row_ref eq "HASH"); + $result .= $row_ref->{bar}." items of ".$row_ref->{baz}.";"; + } + return $result .' '. $array_arg; +$$ LANGUAGE plperl; + +select plperl_array_of_rows(ARRAY[ ROW(2, 'coffee'), ROW(0, 'sugar')]::foo[]); + +-- composite type containing arrays +CREATE TYPE rowfoo AS (bar INTEGER, baz INTEGER[]); + +CREATE OR REPLACE FUNCTION plperl_sum_row_elements(rowfoo) RETURNS TEXT AS $$ + my $row_ref = shift; + my $result; + + if (ref $row_ref ne 'HASH') { + $result = 0; + } + else { + $result = $row_ref->{bar}; + die "not an array reference".ref ($row_ref->{baz}) + unless (is_array_ref($row_ref->{baz})); + # process a single-dimensional array + foreach my $elem (@{$row_ref->{baz}}) { + $result += $elem unless ref $elem; + } + } + return $result; +$$ LANGUAGE plperl; + +select plperl_sum_row_elements(ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo); + +-- composite type containing array of another composite type, which, in order, +-- contains an array of integers. +CREATE TYPE rowbar AS (foo rowfoo[]); + +CREATE OR REPLACE FUNCTION plperl_sum_array_of_rows(rowbar) RETURNS TEXT AS $$ + my $rowfoo_ref = shift; + my $result = 0; + + if (ref $rowfoo_ref eq 'HASH') { + my $row_array_ref = $rowfoo_ref->{foo}; + if (is_array_ref($row_array_ref)) { + foreach my $row_ref (@{$row_array_ref}) { + if (ref $row_ref eq 'HASH') { + $result += $row_ref->{bar}; + die "not an array reference".ref ($row_ref->{baz}) + unless (is_array_ref($row_ref->{baz})); + foreach my $elem (@{$row_ref->{baz}}) { + $result += $elem unless ref $elem; + } + } + else { + die "element baz is not a reference to a rowfoo"; + } + } + } else { + die "not a reference to an array of rowfoo elements" + } + } else { + die "not a reference to type rowbar"; + } + return $result; +$$ LANGUAGE plperl; + +select plperl_sum_array_of_rows(ROW(ARRAY[ROW(1, ARRAY[2,3,4,5,6,7,8,9,10])::rowfoo, +ROW(11, ARRAY[12,13,14,15,16,17,18,19,20])::rowfoo])::rowbar); + +-- check arrays as out parameters +CREATE OR REPLACE FUNCTION plperl_arrays_out(OUT INTEGER[]) AS $$ + return [[1,2,3],[4,5,6]]; +$$ LANGUAGE plperl; + +select plperl_arrays_out(); + +-- check that we can return the array we passed in +CREATE OR REPLACE FUNCTION plperl_arrays_inout(INTEGER[]) returns INTEGER[] AS $$ + return shift; +$$ LANGUAGE plperl; + +select plperl_arrays_inout('{{1}, {2}, {3}}'); + +-- check that we can return an array literal +CREATE OR REPLACE FUNCTION plperl_arrays_inout_l(INTEGER[]) returns INTEGER[] AS $$ + return shift.''; # stringify it +$$ LANGUAGE plperl; + +select plperl_arrays_inout_l('{{1}, {2}, {3}}'); + +-- make sure setof works +create or replace function perl_setof_array(integer[]) returns setof integer[] language plperl as $$ + my $arr = shift; + for my $r (@$arr) { + return_next $r; + } + return undef; +$$; + +select perl_setof_array('{{1}, {2}, {3}}'); diff --git a/src/pl/plperl/sql/plperl_call.sql b/src/pl/plperl/sql/plperl_call.sql new file mode 100644 index 0000000..2cf5461 --- /dev/null +++ b/src/pl/plperl/sql/plperl_call.sql @@ -0,0 +1,58 @@ +CREATE PROCEDURE test_proc1() +LANGUAGE plperl +AS $$ +undef; +$$; + +CALL test_proc1(); + + +CREATE PROCEDURE test_proc2() +LANGUAGE plperl +AS $$ +return 5 +$$; + +CALL test_proc2(); + + +CREATE TABLE test1 (a int); + +CREATE PROCEDURE test_proc3(x int) +LANGUAGE plperl +AS $$ +spi_exec_query("INSERT INTO test1 VALUES ($_[0])"); +$$; + +CALL test_proc3(55); + +SELECT * FROM test1; + + +-- output arguments + +CREATE PROCEDURE test_proc5(INOUT a text) +LANGUAGE plperl +AS $$ +my ($a) = @_; +return { a => "$a+$a" }; +$$; + +CALL test_proc5('abc'); + + +CREATE PROCEDURE test_proc6(a int, INOUT b int, INOUT c int) +LANGUAGE plperl +AS $$ +my ($a, $b, $c) = @_; +return { b => $b * $a, c => $c * $a }; +$$; + +CALL test_proc6(2, 3, 4); + + +DROP PROCEDURE test_proc1; +DROP PROCEDURE test_proc2; +DROP PROCEDURE test_proc3; + +DROP TABLE test1; diff --git a/src/pl/plperl/sql/plperl_elog.sql b/src/pl/plperl/sql/plperl_elog.sql new file mode 100644 index 0000000..9ea1350 --- /dev/null +++ b/src/pl/plperl/sql/plperl_elog.sql @@ -0,0 +1,93 @@ +-- test warnings and errors from plperl + +create or replace function perl_elog(text) returns void language plperl as $$ + + my $msg = shift; + elog(NOTICE,$msg); + +$$; + +select perl_elog('explicit elog'); + +create or replace function perl_warn(text) returns void language plperl as $$ + + my $msg = shift; + warn($msg); + +$$; + +select perl_warn('implicit elog via warn'); + +-- test strict mode on/off + +SET plperl.use_strict = true; + +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global = 2; + return 'uses_global worked'; + +$$; + +select uses_global(); + +SET plperl.use_strict = false; + +create or replace function uses_global() returns text language plperl as $$ + + $global = 1; + $other_global=2; + return 'uses_global worked'; + +$$; + +select uses_global(); + +-- make sure we don't choke on readonly values +do language plperl $$ elog(NOTICE, ${^TAINT}); $$; + +-- test recovery after "die" + +create or replace function just_die() returns void language plperl AS $$ +die "just die"; +$$; + +select just_die(); + +create or replace function die_caller() returns int language plpgsql as $$ +BEGIN + BEGIN + PERFORM just_die(); + EXCEPTION WHEN OTHERS THEN + RAISE NOTICE 'caught die'; + END; + RETURN 1; +END; +$$; + +select die_caller(); + +create or replace function indirect_die_caller() returns int language plperl as $$ +my $prepared = spi_prepare('SELECT die_caller() AS fx'); +my $a = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +my $b = spi_exec_prepared($prepared)->{rows}->[0]->{fx}; +return $a + $b; +$$; + +select indirect_die_caller(); + +-- Test non-ASCII error messages +-- +-- Note: this test case is known to fail if the database encoding is +-- EUC_CN, EUC_JP, EUC_KR, or EUC_TW, for lack of any equivalent to +-- U+00A0 (no-break space) in those encodings. However, testing with +-- plain ASCII data would be rather useless, so we must live with that. + +SET client_encoding TO UTF8; + +create or replace function error_with_nbsp() returns void language plperl as $$ + elog(ERROR, "this message contains a no-break space"); +$$; + +select error_with_nbsp(); diff --git a/src/pl/plperl/sql/plperl_end.sql b/src/pl/plperl/sql/plperl_end.sql new file mode 100644 index 0000000..90f49dc --- /dev/null +++ b/src/pl/plperl/sql/plperl_end.sql @@ -0,0 +1,29 @@ +-- test END block handling + +-- Not included in the normal testing +-- because it's beyond the scope of the test harness. +-- Available here for manual developer testing. + +DO $do$ + my $testlog = "/tmp/pgplperl_test.log"; + + warn "Run test, then examine contents of $testlog (which must already exist)\n"; + return unless -f $testlog; + + use IO::Handle; # for autoflush + open my $fh, '>', $testlog + or die "Can't write to $testlog: $!"; + $fh->autoflush(1); + + print $fh "# you should see just 3 'Warn: ...' lines: PRE, END and SPI ...\n"; + $SIG{__WARN__} = sub { print $fh "Warn: @_" }; + $SIG{__DIE__} = sub { print $fh "Die: @_" unless $^S; die @_ }; + + END { + warn "END\n"; + eval { spi_exec_query("select 1") }; + warn $@; + } + warn "PRE\n"; + +$do$ language plperlu; diff --git a/src/pl/plperl/sql/plperl_init.sql b/src/pl/plperl/sql/plperl_init.sql new file mode 100644 index 0000000..4ebf3f8 --- /dev/null +++ b/src/pl/plperl/sql/plperl_init.sql @@ -0,0 +1,10 @@ +-- test plperl.on_plperl_init errors are fatal + +-- This test tests setting on_plperl_init after loading plperl +LOAD 'plperl'; + +SET SESSION plperl.on_plperl_init = ' system("/nonesuch"); '; + +SHOW plperl.on_plperl_init; + +DO $$ warn 42 $$ language plperl; diff --git a/src/pl/plperl/sql/plperl_lc.sql b/src/pl/plperl/sql/plperl_lc.sql new file mode 100644 index 0000000..a4a06e7 --- /dev/null +++ b/src/pl/plperl/sql/plperl_lc.sql @@ -0,0 +1,8 @@ +-- +-- Make sure strings are validated +-- Should fail for all encodings, as nul bytes are never permitted. +-- +CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$ + return "abcd\0efg"; +$$ LANGUAGE plperl; +SELECT perl_zerob(); diff --git a/src/pl/plperl/sql/plperl_plperlu.sql b/src/pl/plperl/sql/plperl_plperlu.sql new file mode 100644 index 0000000..bbd79b6 --- /dev/null +++ b/src/pl/plperl/sql/plperl_plperlu.sql @@ -0,0 +1,58 @@ +-- test plperl/plperlu interaction + +-- the language and call ordering of this test sequence is useful + +CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$ + #die 'BANG!'; # causes server process to exit(2) + # alternative - causes server process to exit(255) + spi_exec_query("invalid sql statement"); +$$ language plperl; -- compile plperl code + +CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$ + spi_exec_query("SELECT * FROM bar()"); + return 1; +$$ LANGUAGE plperlu; -- compile plperlu code + +SELECT * FROM bar(); -- throws exception normally (running plperl) +SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu) + +-- test redefinition of specific SP switching languages +-- http://archives.postgresql.org/pgsql-bugs/2010-01/msg00116.php + +-- plperl first +create or replace function foo(text) returns text language plperl as 'shift'; +select foo('hey'); +create or replace function foo(text) returns text language plperlu as 'shift'; +select foo('hey'); +create or replace function foo(text) returns text language plperl as 'shift'; +select foo('hey'); + +-- plperlu first +create or replace function bar(text) returns text language plperlu as 'shift'; +select bar('hey'); +create or replace function bar(text) returns text language plperl as 'shift'; +select bar('hey'); +create or replace function bar(text) returns text language plperlu as 'shift'; +select bar('hey'); + +-- +-- Make sure we can't use/require things in plperl +-- + +CREATE OR REPLACE FUNCTION use_plperlu() RETURNS void LANGUAGE plperlu +AS $$ +use Errno; +$$; + +CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl +AS $$ +use Errno; +$$; + +-- make sure our overloaded require op gets restored/set correctly +select use_plperlu(); + +CREATE OR REPLACE FUNCTION use_plperl() RETURNS void LANGUAGE plperl +AS $$ +use Errno; +$$; diff --git a/src/pl/plperl/sql/plperl_setup.sql b/src/pl/plperl/sql/plperl_setup.sql new file mode 100644 index 0000000..7484478 --- /dev/null +++ b/src/pl/plperl/sql/plperl_setup.sql @@ -0,0 +1,69 @@ +-- +-- Install the plperl and plperlu extensions +-- + +-- Before going ahead with the to-be-tested installations, verify that +-- a non-superuser is allowed to install plperl (but not plperlu) when +-- suitable permissions have been granted. + +CREATE USER regress_user1; +CREATE USER regress_user2; + +SET ROLE regress_user1; + +CREATE EXTENSION plperl; -- fail +CREATE EXTENSION plperlu; -- fail + +RESET ROLE; + +DO $$ +begin + execute format('grant create on database %I to regress_user1', + current_database()); +end; +$$; + +SET ROLE regress_user1; + +CREATE EXTENSION plperl; +CREATE EXTENSION plperlu; -- fail + +CREATE FUNCTION foo1() returns int language plperl as '1;'; +SELECT foo1(); + +-- Must reconnect to avoid failure with non-MULTIPLICITY Perl interpreters +\c - + +SET ROLE regress_user1; + +-- Should be able to change privileges on the language +revoke all on language plperl from public; + +SET ROLE regress_user2; + +CREATE FUNCTION foo2() returns int language plperl as '2;'; -- fail + +SET ROLE regress_user1; + +grant usage on language plperl to regress_user2; + +SET ROLE regress_user2; + +CREATE FUNCTION foo2() returns int language plperl as '2;'; +SELECT foo2(); + +SET ROLE regress_user1; + +-- Should be able to drop the extension, but not the language per se +DROP LANGUAGE plperl CASCADE; +DROP EXTENSION plperl CASCADE; + +-- Clean up +RESET ROLE; +DROP OWNED BY regress_user1; +DROP USER regress_user1; +DROP USER regress_user2; + +-- Now install the versions that will be used by subsequent test scripts. +CREATE EXTENSION plperl; +CREATE EXTENSION plperlu; diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql new file mode 100644 index 0000000..b60e114 --- /dev/null +++ b/src/pl/plperl/sql/plperl_shared.sql @@ -0,0 +1,41 @@ +-- test plperl.on_plperl_init via the shared hash +-- (must be done before plperl is first used) + +-- This test tests setting on_plperl_init before loading plperl + +-- testing on_plperl_init gets run, and that it can alter %_SHARED +SET plperl.on_plperl_init = '$_SHARED{on_init} = 42'; + +-- test the shared hash + +create function setme(key text, val text) returns void language plperl as $$ + + my $key = shift; + my $val = shift; + $_SHARED{$key}= $val; + +$$; + +create function getme(key text) returns text language plperl as $$ + + my $key = shift; + return $_SHARED{$key}; + +$$; + +select setme('ourkey','ourval'); + +select getme('ourkey'); + +select getme('on_init'); + +-- verify that we can use $_SHARED in strict mode +create or replace function perl_shared() returns int as $$ +use strict; +my $val = $_SHARED{'stuff'}; +$_SHARED{'stuff'} = '1'; +return $val; +$$ language plperl; + +select perl_shared(); +select perl_shared(); diff --git a/src/pl/plperl/sql/plperl_transaction.sql b/src/pl/plperl/sql/plperl_transaction.sql new file mode 100644 index 0000000..0a60799 --- /dev/null +++ b/src/pl/plperl/sql/plperl_transaction.sql @@ -0,0 +1,163 @@ +CREATE TABLE test1 (a int, b text); + + +CREATE PROCEDURE transaction_test1() +LANGUAGE plperl +AS $$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; + +CALL transaction_test1(); + +SELECT * FROM test1; + + +TRUNCATE test1; + +DO +LANGUAGE plperl +$$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; + +SELECT * FROM test1; + + +TRUNCATE test1; + +-- not allowed in a function +CREATE FUNCTION transaction_test2() RETURNS int +LANGUAGE plperl +AS $$ +foreach my $i (0..9) { + spi_exec_query("INSERT INTO test1 (a) VALUES ($i)"); + if ($i % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +return 1; +$$; + +SELECT transaction_test2(); + +SELECT * FROM test1; + + +-- also not allowed if procedure is called from a function +CREATE FUNCTION transaction_test3() RETURNS int +LANGUAGE plperl +AS $$ +spi_exec_query("CALL transaction_test1()"); +return 1; +$$; + +SELECT transaction_test3(); + +SELECT * FROM test1; + + +-- DO block inside function +CREATE FUNCTION transaction_test4() RETURNS int +LANGUAGE plperl +AS $$ +spi_exec_query('DO LANGUAGE plperl $x$ spi_commit(); $x$'); +return 1; +$$; + +SELECT transaction_test4(); + + +-- commit inside cursor loop +CREATE TABLE test2 (x int); +INSERT INTO test2 VALUES (0), (1), (2), (3), (4); + +TRUNCATE test1; + +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + spi_commit(); +} +$$; + +SELECT * FROM test1; + +-- check that this doesn't leak a holdable portal +SELECT * FROM pg_cursors; + + +-- error in cursor loop with commit +TRUNCATE test1; + +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (12/(" . $row->{x} . "-2))"); + spi_commit(); +} +$$; + +SELECT * FROM test1; + +SELECT * FROM pg_cursors; + + +-- rollback inside cursor loop +TRUNCATE test1; + +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + spi_rollback(); +} +$$; + +SELECT * FROM test1; + +SELECT * FROM pg_cursors; + + +-- first commit then rollback inside cursor loop +TRUNCATE test1; + +DO LANGUAGE plperl $$ +my $sth = spi_query("SELECT * FROM test2 ORDER BY x"); +my $row; +while (defined($row = spi_fetchrow($sth))) { + spi_exec_query("INSERT INTO test1 (a) VALUES (" . $row->{x} . ")"); + if ($row->{x} % 2 == 0) { + spi_commit(); + } else { + spi_rollback(); + } +} +$$; + +SELECT * FROM test1; + +SELECT * FROM pg_cursors; + + +DROP TABLE test1; +DROP TABLE test2; diff --git a/src/pl/plperl/sql/plperl_trigger.sql b/src/pl/plperl/sql/plperl_trigger.sql new file mode 100644 index 0000000..4adddeb --- /dev/null +++ b/src/pl/plperl/sql/plperl_trigger.sql @@ -0,0 +1,259 @@ +-- test plperl triggers + +CREATE TYPE rowcomp as (i int); +CREATE TYPE rowcompnest as (rfoo rowcomp); +CREATE TABLE trigger_test ( + i int, + v varchar, + foo rowcompnest +); + +CREATE TABLE trigger_test_generated ( + i int, + j int GENERATED ALWAYS AS (i * 2) STORED +); + +CREATE OR REPLACE FUNCTION trigger_data() RETURNS trigger LANGUAGE plperl AS $$ + + # make sure keys are sorted for consistent results - perl no longer + # hashes in repeatable fashion across runs + + sub str { + my $val = shift; + + if (!defined $val) + { + return 'NULL'; + } + elsif (ref $val eq 'HASH') + { + my $str = ''; + foreach my $rowkey (sort keys %$val) + { + $str .= ", " if $str; + my $rowval = str($val->{$rowkey}); + $str .= "'$rowkey' => $rowval"; + } + return '{'. $str .'}'; + } + elsif (ref $val eq 'ARRAY') + { + my $str = ''; + for my $argval (@$val) + { + $str .= ", " if $str; + $str .= str($argval); + } + return '['. $str .']'; + } + else + { + return "'$val'"; + } + } + + foreach my $key (sort keys %$_TD) + { + + my $val = $_TD->{$key}; + + # relid is variable, so we can not use it repeatably + $val = "bogus:12345" if $key eq 'relid'; + + elog(NOTICE, "\$_TD->\{$key\} = ". str($val)); + } + return undef; # allow statement to proceed; +$$; + +CREATE TRIGGER show_trigger_data_trig +BEFORE INSERT OR UPDATE OR DELETE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE trigger_data(23,'skidoo'); + +insert into trigger_test values(1,'insert', '("(1)")'); +update trigger_test set v = 'update' where i = 1; +delete from trigger_test; + +DROP TRIGGER show_trigger_data_trig on trigger_test; + +CREATE TRIGGER show_trigger_data_trig_before +BEFORE INSERT OR UPDATE OR DELETE ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE trigger_data(); + +CREATE TRIGGER show_trigger_data_trig_after +AFTER INSERT OR UPDATE OR DELETE ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE trigger_data(); + +insert into trigger_test_generated (i) values (1); +update trigger_test_generated set i = 11 where i = 1; +delete from trigger_test_generated; + +DROP TRIGGER show_trigger_data_trig_before ON trigger_test_generated; +DROP TRIGGER show_trigger_data_trig_after ON trigger_test_generated; + +insert into trigger_test values(1,'insert', '("(1)")'); +CREATE VIEW trigger_test_view AS SELECT * FROM trigger_test; + +CREATE TRIGGER show_trigger_data_trig +INSTEAD OF INSERT OR UPDATE OR DELETE ON trigger_test_view +FOR EACH ROW EXECUTE PROCEDURE trigger_data(24,'skidoo view'); + +insert into trigger_test_view values(2,'insert', '("(2)")'); +update trigger_test_view set v = 'update', foo = '("(3)")' where i = 1; +delete from trigger_test_view; + +DROP VIEW trigger_test_view; +delete from trigger_test; + +DROP FUNCTION trigger_data(); + +CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$ + + if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0)) + { + return "SKIP"; # Skip INSERT/UPDATE command + } + elsif ($_TD->{new}{v} ne "immortal") + { + $_TD->{new}{v} .= "(modified by trigger)"; + $_TD->{new}{foo}{rfoo}{i}++; + return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command + } + else + { + return; # Proceed INSERT/UPDATE command + } +$$ LANGUAGE plperl; + +CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE "valid_id"(); + +INSERT INTO trigger_test (i, v, foo) VALUES (1,'first line', '("(1)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (2,'second line', '("(2)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (3,'third line', '("(3)")'); +INSERT INTO trigger_test (i, v, foo) VALUES (4,'immortal', '("(4)")'); + +INSERT INTO trigger_test (i, v) VALUES (101,'bad id'); + +SELECT * FROM trigger_test; + +UPDATE trigger_test SET i = 5 where i=3; + +UPDATE trigger_test SET i = 100 where i=1; + +SELECT * FROM trigger_test; + +DROP TRIGGER "test_valid_id_trig" ON trigger_test; + +CREATE OR REPLACE FUNCTION trigger_recurse() RETURNS trigger AS $$ + use strict; + + if ($_TD->{new}{i} == 10000) + { + spi_exec_query("insert into trigger_test (i, v) values (20000, 'child');"); + + if ($_TD->{new}{i} != 10000) + { + die "recursive trigger modified: ". $_TD->{new}{i}; + } + } + return; +$$ LANGUAGE plperl; + +CREATE TRIGGER "test_trigger_recurse" BEFORE INSERT ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE "trigger_recurse"(); + +INSERT INTO trigger_test (i, v) values (10000, 'top'); + +SELECT * FROM trigger_test; + +CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$ + if ($_TD->{old}{v} eq $_TD->{args}[0]) + { + return "SKIP"; # Skip DELETE command + } + else + { + return; # Proceed DELETE command + }; +$$ LANGUAGE plperl; + +CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test +FOR EACH ROW EXECUTE PROCEDURE immortal('immortal'); + +DELETE FROM trigger_test; + +SELECT * FROM trigger_test; + +CREATE FUNCTION direct_trigger() RETURNS trigger AS $$ + return; +$$ LANGUAGE plperl; + +SELECT direct_trigger(); + +-- check that SQL run in trigger code can see transition tables + +CREATE TABLE transition_table_test (id int, name text); +INSERT INTO transition_table_test VALUES (1, 'a'); + +CREATE FUNCTION transition_table_test_f() RETURNS trigger LANGUAGE plperl AS +$$ + my $cursor = spi_query("SELECT * FROM old_table"); + my $row = spi_fetchrow($cursor); + defined($row) || die "expected a row"; + elog(INFO, "old: " . $row->{id} . " -> " . $row->{name}); + my $row = spi_fetchrow($cursor); + !defined($row) || die "expected no more rows"; + + my $cursor = spi_query("SELECT * FROM new_table"); + my $row = spi_fetchrow($cursor); + defined($row) || die "expected a row"; + elog(INFO, "new: " . $row->{id} . " -> " . $row->{name}); + my $row = spi_fetchrow($cursor); + !defined($row) || die "expected no more rows"; + + return undef; +$$; + +CREATE TRIGGER a_t AFTER UPDATE ON transition_table_test + REFERENCING OLD TABLE AS old_table NEW TABLE AS new_table + FOR EACH STATEMENT EXECUTE PROCEDURE transition_table_test_f(); +UPDATE transition_table_test SET name = 'b'; + +DROP TABLE transition_table_test; +DROP FUNCTION transition_table_test_f(); + +-- test plperl command triggers +create or replace function perlsnitch() returns event_trigger language plperl as $$ + elog(NOTICE, "perlsnitch: " . $_TD->{event} . " " . $_TD->{tag} . " "); +$$; + +create event trigger perl_a_snitch on ddl_command_start + execute procedure perlsnitch(); +create event trigger perl_b_snitch on ddl_command_end + execute procedure perlsnitch(); + +create or replace function foobar() returns int language sql as $$select 1;$$; +alter function foobar() cost 77; +drop function foobar(); + +create table foo(); +drop table foo; + +drop event trigger perl_a_snitch; +drop event trigger perl_b_snitch; + +-- dealing with generated columns + +CREATE FUNCTION generated_test_func1() RETURNS trigger +LANGUAGE plperl +AS $$ +$_TD->{new}{j} = 5; # not allowed +return 'MODIFY'; +$$; + +CREATE TRIGGER generated_test_trigger1 BEFORE INSERT ON trigger_test_generated +FOR EACH ROW EXECUTE PROCEDURE generated_test_func1(); + +TRUNCATE trigger_test_generated; +INSERT INTO trigger_test_generated (i) VALUES (1); +SELECT * FROM trigger_test_generated; diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql new file mode 100644 index 0000000..5b31605 --- /dev/null +++ b/src/pl/plperl/sql/plperl_util.sql @@ -0,0 +1,121 @@ +-- 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 quote_nullable($_).": ". (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 + ' ', # only space + ''; # empty string + return undef; +$$; + +select perl_looks_like_number(); + +-- test encode_typed_literal +create type perl_foo as (a integer, b text[]); +create type perl_bar as (c perl_foo[]); +create domain perl_foo_pos as perl_foo check((value).a > 0); + +create or replace function perl_encode_typed_literal() returns setof text language plperl as $$ + return_next encode_typed_literal(undef, 'text'); + return_next encode_typed_literal([[1,2,3],[3,2,1],[1,3,2]], 'integer[]'); + return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo'); + return_next encode_typed_literal({c => [{a => 9, b => ['PostgreSQL']}, {b => ['Postgres'], a => 1}]}, 'perl_bar'); + return_next encode_typed_literal({a => 1, b => ['PL','/','Perl']}, 'perl_foo_pos'); +$$; + +select perl_encode_typed_literal(); + +create or replace function perl_encode_typed_literal() returns setof text language plperl as $$ + return_next encode_typed_literal({a => 0, b => ['PL','/','Perl']}, 'perl_foo_pos'); +$$; + +select perl_encode_typed_literal(); -- fail diff --git a/src/pl/plperl/sql/plperlu.sql b/src/pl/plperl/sql/plperlu.sql new file mode 100644 index 0000000..be43df5 --- /dev/null +++ b/src/pl/plperl/sql/plperlu.sql @@ -0,0 +1,17 @@ +-- Use ONLY plperlu tests here. For plperl/plerlu combined tests +-- see plperl_plperlu.sql + +-- This test tests setting on_plperlu_init after loading plperl +LOAD 'plperl'; + +-- Test plperl.on_plperlu_init gets run +SET plperl.on_plperlu_init = '$_SHARED{init} = 42'; +DO $$ warn $_SHARED{init} $$ language plperlu; + +-- +-- Test compilation of unicode regex - regardless of locale. +-- This code fails in plain plperl in a non-UTF8 database. +-- +CREATE OR REPLACE FUNCTION perl_unicode_regex(text) RETURNS INTEGER AS $$ + return ($_[0] =~ /\x{263A}|happy/i) ? 1 : 0; # unicode smiley +$$ LANGUAGE plperlu; diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl new file mode 100644 index 0000000..52fcbe1 --- /dev/null +++ b/src/pl/plperl/text2macro.pl @@ -0,0 +1,103 @@ +# src/pl/plperl/text2macro.pl + +=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 + * Generated by src/pl/plperl/text2macro.pl + */ +}; + +for my $src_file (@ARGV) +{ + + (my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x; + + open my $src_fh, '<', $src_file + 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"; + return; +} |