HAWQ-744. Add plperl code
Project: http://git-wip-us.apache.org/repos/asf/incubator-hawq/repo Commit: http://git-wip-us.apache.org/repos/asf/incubator-hawq/commit/120ee70b Tree: http://git-wip-us.apache.org/repos/asf/incubator-hawq/tree/120ee70b Diff: http://git-wip-us.apache.org/repos/asf/incubator-hawq/diff/120ee70b Branch: refs/heads/master Commit: 120ee70ba296872fc9c1a20d59c0303f188e2226 Parents: 970edfe Author: Paul Guo <[email protected]> Authored: Thu May 19 18:41:12 2016 +0800 Committer: Ruilong Huo <[email protected]> Committed: Fri May 20 18:20:52 2016 +0800 ---------------------------------------------------------------------- src/pl/Makefile | 4 + src/pl/plperl/.gitignore | 15 + src/pl/plperl/.p4ignore | 6 + src/pl/plperl/GNUmakefile | 108 + src/pl/plperl/README | 10 + src/pl/plperl/SPI.xs | 186 + src/pl/plperl/Util.xs | 218 + src/pl/plperl/expected/plperl.out | 602 ++ src/pl/plperl/expected/plperl_array.out | 166 + src/pl/plperl/expected/plperl_elog.out | 60 + src/pl/plperl/expected/plperl_init.out | 10 + src/pl/plperl/expected/plperl_plperlu.out | 95 + src/pl/plperl/expected/plperl_shared.out | 26 + src/pl/plperl/expected/plperl_stress.out | 38 + src/pl/plperl/expected/plperl_trigger.out | 206 + src/pl/plperl/expected/plperl_util.out | 167 + src/pl/plperl/expected/plperlu.out | 13 + src/pl/plperl/nls.mk | 5 + src/pl/plperl/plc_perlboot.pl | 105 + src/pl/plperl/plc_trusted.pl | 27 + src/pl/plperl/plperl--1.0.sql | 9 + src/pl/plperl/plperl--unpackaged--1.0.sql | 7 + src/pl/plperl/plperl.c | 3778 ++++++++++++ src/pl/plperl/plperl.control | 7 + src/pl/plperl/plperl.h | 133 + src/pl/plperl/plperl_helpers.h | 91 + src/pl/plperl/plperl_opmask.pl | 58 + src/pl/plperl/plperlu--1.0.sql | 9 + src/pl/plperl/plperlu--unpackaged--1.0.sql | 7 + src/pl/plperl/plperlu.control | 7 + src/pl/plperl/po/.gitignore | 8 + src/pl/plperl/po/.p4ignore | 8 + src/pl/plperl/po/de.po | 105 + src/pl/plperl/po/es.po | 115 + src/pl/plperl/po/fr.po | 115 + src/pl/plperl/po/it.po | 113 + src/pl/plperl/po/ja.po | 100 + src/pl/plperl/po/pt_BR.po | 105 + src/pl/plperl/po/tr.po | 100 + src/pl/plperl/ppport.h | 7064 +++++++++++++++++++++++ src/pl/plperl/sql/plperl.sql | 388 ++ src/pl/plperl/sql/plperl_array.sql | 113 + src/pl/plperl/sql/plperl_elog.sql | 45 + src/pl/plperl/sql/plperl_end.sql | 29 + src/pl/plperl/sql/plperl_init.sql | 9 + src/pl/plperl/sql/plperl_plperlu.sql | 58 + src/pl/plperl/sql/plperl_shared.sql | 22 + src/pl/plperl/sql/plperl_stress.sql | 54 + src/pl/plperl/sql/plperl_trigger.sql | 133 + src/pl/plperl/sql/plperl_util.sql | 101 + src/pl/plperl/sql/plperlu.sql | 16 + src/pl/plperl/text2macro.pl | 100 + 52 files changed, 15074 insertions(+) ---------------------------------------------------------------------- http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/Makefile ---------------------------------------------------------------------- diff --git a/src/pl/Makefile b/src/pl/Makefile index eda6d30..31d9bb9 100644 --- a/src/pl/Makefile +++ b/src/pl/Makefile @@ -26,6 +26,10 @@ ifeq ($(with_java), yes) DIRS += pljava endif +ifeq ($(with_perl), yes) +DIRS += plperl +endif + all install installdirs uninstall distprep: @for dir in $(DIRS); do $(MAKE) -C $$dir $@ || exit 1; done http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/.gitignore ---------------------------------------------------------------------- diff --git a/src/pl/plperl/.gitignore b/src/pl/plperl/.gitignore new file mode 100644 index 0000000..503f43d --- /dev/null +++ b/src/pl/plperl/.gitignore @@ -0,0 +1,15 @@ +/SPI.c +/Util.c +/perlchunks.h +/plperl_opmask.h + +# Generated subdirectories +/log/ +/results/ +/tmp_check/ +libplperl.so.0 +libplperl.so.0.0 +libplperl.so +libplperl.a +SPI.c +plperl.so http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/.p4ignore ---------------------------------------------------------------------- diff --git a/src/pl/plperl/.p4ignore b/src/pl/plperl/.p4ignore new file mode 100644 index 0000000..4078738 --- /dev/null +++ b/src/pl/plperl/.p4ignore @@ -0,0 +1,6 @@ +libplperl.so.0 +libplperl.so.0.0 +libplperl.so +libplperl.a +SPI.c +plperl.so http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/GNUmakefile ---------------------------------------------------------------------- diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile new file mode 100644 index 0000000..d480268 --- /dev/null +++ b/src/pl/plperl/GNUmakefile @@ -0,0 +1,108 @@ +# Makefile for PL/Perl +# PostgreSQL: pgsql/src/pl/plperl/GNUmakefile + +subdir = src/pl/plperl +top_builddir = ../../.. +-include $(top_builddir)/src/Makefile.global + +ifeq ($(perl_useshrplib),true) +shared_libperl = yes +endif +ifeq ($(perl_useshrplib),yes) +shared_libperl = yes +endif + +# If we don't have a shared library and the platform doesn't allow it +# to work without, we have to skip it. +ifneq (,$(findstring yes, $(shared_libperl)$(allow_nonpic_in_shlib))) + +ifeq ($(PORTNAME), win32) +perl_archlibexp := $(subst \,/,$(perl_archlibexp)) +perl_privlibexp := $(subst \,/,$(perl_privlibexp)) +perl_lib := $(basename $(notdir $(wildcard $(perl_archlibexp)/CORE/perl[5-9]*.lib))) +perl_embed_ldflags = -L$(perl_archlibexp)/CORE -l$(perl_lib) +override CPPFLAGS += -DPLPERL_HAVE_UID_GID +# Perl on win32 contains /* within comment all over the header file, +# so disable this warning. +override CFLAGS += -Wno-comment +endif + +override CPPFLAGS := -I$(srcdir) $(CPPFLAGS) -I$(perl_archlibexp)/CORE + +rpathdir = $(perl_archlibexp)/CORE + + +NAME = plperl + +OBJS = plperl.o SPI.o Util.o + +DATA = plperl.control plperl--1.0.sql plperl--unpackaged--1.0.sql \ + plperlu.control plperlu--1.0.sql plperlu--unpackaged--1.0.sql + +PERLCHUNKS = plc_perlboot.pl plc_trusted.pl + +SHLIB_LINK = $(perl_embed_ldflags) + +REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu +REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array +STRESS = plperl_stress +# 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 psql for running the tests +PSQLDIR = $(bindir) + +include $(top_srcdir)/src/Makefile.shlib + +plperl.o: perlchunks.h plperl_opmask.h + +plperl_opmask.h: plperl_opmask.pl + $(PERL) $< $@ + +perlchunks.h: $(PERLCHUNKS) + $(PERL) $(srcdir)/text2macro.pl --strip='^(\#.*|\s*)$$' $^ > $@ + +all: all-lib + +SPI.c: SPI.xs + $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ + +Util.c: Util.xs + $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ + +install: all installdirs install-lib + +installdirs: installdirs-lib + +uninstall: uninstall-lib + +installcheck: submake + $(top_builddir)/src/test/regress/pg_regress --inputdir=$(srcdir) --psqldir=$(PSQLDIR) $(REGRESS_OPTS) $(REGRESS) + +installcheck-stress: submake + $(top_builddir)/src/test/regress/pg_regress --inputdir=$(srcdir) --psqldir=$(PSQLDIR) $(REGRESS_OPTS) $(STRESS) + + +.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 results + rm -f regression.diffs regression.out + +else # can't build + +all: + @echo ""; \ + echo "*** Cannot build PL/Perl because libperl is not a shared library."; \ + echo "*** You might have to rebuild your Perl installation. Refer to"; \ + echo "*** the documentation for details."; \ + echo "" + +endif # can't build http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/README ---------------------------------------------------------------------- diff --git a/src/pl/plperl/README b/src/pl/plperl/README new file mode 100644 index 0000000..d3ccd14 --- /dev/null +++ b/src/pl/plperl/README @@ -0,0 +1,10 @@ +$PostgreSQL: pgsql/src/pl/plperl/README,v 1.4 2008/03/21 13:23:29 momjian Exp $ + +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 'gmake all; gmake 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. http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/SPI.xs ---------------------------------------------------------------------- diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs new file mode 100755 index 0000000..588d77b --- /dev/null +++ b/src/pl/plperl/SPI.xs @@ -0,0 +1,186 @@ +/********************************************************************** + * PostgreSQL::InServer::SPI + * + * SPI interface for plperl. + * + * src/pl/plperl/SPI.xs + * + **********************************************************************/ + +/* this must be first: */ +#include "postgres.h" +#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */ + +/* Defined by Perl */ +#undef _ + +/* perl stuff */ +#include "plperl.h" +#include "plperl_helpers.h" + + +/* + * Interface routine to catch ereports and punt them to Perl + */ +static void +do_plperl_return_next(SV *sv) +{ + MemoryContext oldcontext = CurrentMemoryContext; + + PG_TRY(); + { + plperl_return_next(sv); + } + PG_CATCH(); + { + ErrorData *edata; + + /* Must reset elog.c's state */ + MemoryContextSwitchTo(oldcontext); + edata = CopyErrorData(); + FlushErrorState(); + + /* Punt the error to Perl */ + croak("%s", edata->message); + } + PG_END_TRY(); +} + + +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: + do_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); + + +BOOT: + items = 0; /* avoid 'unused variable' warning */ + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/Util.xs ---------------------------------------------------------------------- diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs new file mode 100644 index 0000000..7d0102b --- /dev/null +++ b/src/pl/plperl/Util.xs @@ -0,0 +1,218 @@ +/********************************************************************** + * 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 */ +#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */ +/* Defined by Perl */ +#undef _ + +/* perl stuff */ +#include "plperl.h" +#include "plperl_helpers.h" + +/* + * Implementation of plperl's elog() function + * + * If the error level is less than ERROR, we'll just emit the message and + * return. When it is ERROR, elog() will longjmp, which we catch and + * turn into a Perl croak(). Note we are assuming that elog() can't have + * any internal failures that are so bad as to require a transaction abort. + * + * This is out-of-line to suppress "might be clobbered by longjmp" warnings. + */ +static void +do_util_elog(int level, 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("%s", edata->message); + } + PG_END_TRY(); +} + +static text * +sv2text(SV *sv) +{ + char *str = sv2cstr(sv); + + return cstring_to_text(str); +} + +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; + do_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 *ret = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg))); + char *str = text_to_cstring(ret); + 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 *ret = DatumGetTextP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg))); + char *str = text_to_cstring(ret); + RETVAL = cstr2sv(str); + pfree(str); + } + OUTPUT: + RETVAL + +SV * +util_quote_ident(sv) + SV *sv + PREINIT: + text *arg; + text *ret; + char *str; + CODE: + arg = sv2text(sv); + ret = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg))); + str = text_to_cstring(ret); + 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 = DatumGetTextP(DirectFunctionCall1(byteain, PointerGetDatum(arg))); + /* not cstr2sv because this is raw bytes not utf8'able */ + RETVAL = newSVpvn(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ)); + OUTPUT: + RETVAL + +SV * +util_encode_bytea(sv) + SV *sv + PREINIT: + text *arg; + char *ret; + 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 */ http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out new file mode 100755 index 0000000..24102ba --- /dev/null +++ b/src/pl/plperl/expected/plperl.out @@ -0,0 +1,602 @@ +-- +-- 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) + +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(); +ERROR: Unsupported Perl function "perl_record_set" +DETAIL: function returning record called in context that cannot accept type record +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: Unsupported Perl function "perl_record_set" +DETAIL: 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: Unsupported Perl function "perl_record_set" +DETAIL: 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: composite-returning PL/Perl function must return reference to hash +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: composite-returning PL/Perl function must return reference to hash +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" +-- +-- 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) + +-- +-- 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: Perl function "perl_spi_prepared_bad" failed (SOMEFILE:SOMEFUNC) +DETAIL: 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) + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_array.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_array.out b/src/pl/plperl/expected/plperl_array.out new file mode 100644 index 0000000..90bfa61 --- /dev/null +++ b/src/pl/plperl/expected/plperl_array.out @@ -0,0 +1,166 @@ +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 (6) 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: multidimensional arrays must have array expressions with matching dimensions +LINE 1: select plperl_sum_array('{{{1,2,3}, {4,5,6,7}}, {{7,8,9}, {1... + ^ +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) + +-- 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) + +-- 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) + +-- 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) + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_elog.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out new file mode 100755 index 0000000..471b8a0 --- /dev/null +++ b/src/pl/plperl/expected/plperl_elog.out @@ -0,0 +1,60 @@ +-- 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 +CONTEXT: PL/Perl function "perl_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. +CONTEXT: PL/Perl function "perl_warn" + 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: creation of Perl function failed +DETAIL: Global symbol "$global" requires explicit package name at line 3. +Global symbol "$other_global" requires explicit package name at line 4. +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) + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_init.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_init.out b/src/pl/plperl/expected/plperl_init.out new file mode 100644 index 0000000..5666b3f --- /dev/null +++ b/src/pl/plperl/expected/plperl_init.out @@ -0,0 +1,10 @@ +-- test plperl.on_plperl_init errors are fatal +-- Avoid need for custom_variable_classes = 'plperl' +LOAD 'plperl'; +SET SESSION plperl.on_plperl_init = ' system("/nonesuch") '; +SHOW plperl.on_plperl_init; + plperl.on_plperl_init +----------------------- + system("/nonesuch") +(1 row) + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_plperlu.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_plperlu.out b/src/pl/plperl/expected/plperl_plperlu.out new file mode 100644 index 0000000..be96c46 --- /dev/null +++ b/src/pl/plperl/expected/plperl_plperlu.out @@ -0,0 +1,95 @@ +-- 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: Perl function "bar" failed (plperl.c:1961) +DETAIL: 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: Perl function "foo" failed (plperl.c:1961) +DETAIL: Perl function "bar" failed 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: creation of Perl function failed +DETAIL: 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: creation of Perl function failed +DETAIL: 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" http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_shared.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out new file mode 100755 index 0000000..72ae1ba --- /dev/null +++ b/src/pl/plperl/expected/plperl_shared.out @@ -0,0 +1,26 @@ +-- 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) + http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_stress.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_stress.out b/src/pl/plperl/expected/plperl_stress.out new file mode 100644 index 0000000..9a0ea81 --- /dev/null +++ b/src/pl/plperl/expected/plperl_stress.out @@ -0,0 +1,38 @@ +--Test to return large scale data over a table with large number of rows, +--and each result set is of different size. +CREATE TABLE test (a int) DISTRIBUTED RANDOMLY; +CREATE TABLE table10000 AS SELECT * from generate_series(1,10000) DISTRIBUTED RANDOMLY; +-- Create Function to return setof random number of integers +-- +CREATE OR REPLACE FUNCTION setof_int() +RETURNS SETOF INTEGER AS $$ + my $range = 20000; + my $random_number = int(rand($range)); + foreach (1..$random_number) { + return_next(1); + } + return undef; +$$ LANGUAGE plperl; +--(1) Return " setof integer " with ten thousands of tuplestores and each tuplestore containing random number(1â¦20000) of integers, +-- so totally handle about 400 Megabytes. +CREATE TABLE setofIntRes AS SELECT setof_int() from table10000 DISTRIBUTED RANDOMLY; +DROP TABLE setofIntRes; +DROP FUNCTION setof_int(); +--Create Function to return setof random number of rows +-- +CREATE OR REPLACE FUNCTION setof_table_random () +RETURNS SETOF test AS $$ + my $range = 20000; + my $random_number = int(rand($range)); + foreach (1..$random_number) { + return_next({a=>1}); + } + return undef; +$$ LANGUAGE plperl; +--(2) Return "setof table" with ten thousands of tuplestores and each tuplestore containing random number(1â¦20000) of rows(each row just has one int +-- column),so totally handle about 400 Megabytes. +CREATE TABLE setofTableRes AS SELECT setof_table_random() from table10000 DISTRIBUTED RANDOMLY; +DROP TABLE setofTableRes; +DROP FUNCTION setof_table_random (); +DROP TABLE test; +DROP TABLE table10000; http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_trigger.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out new file mode 100755 index 0000000..3e4c25d --- /dev/null +++ b/src/pl/plperl/expected/plperl_trigger.out @@ -0,0 +1,206 @@ +-- 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 +) distributed by (i); +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' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{args} = ['23', 'skidoo'] +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{event} = 'INSERT' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{level} = 'ROW' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relid} = 'bogus:12345' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relname} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_name} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_schema} = 'public' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{when} = 'BEFORE' +CONTEXT: PL/Perl function "trigger_data" +update trigger_test set v = 'update' where i = 1; +NOTICE: $_TD->{argc} = '2' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{args} = ['23', 'skidoo'] +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{event} = 'UPDATE' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{level} = 'ROW' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{new} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'} +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'insert'} +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relid} = 'bogus:12345' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relname} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_name} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_schema} = 'public' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{when} = 'BEFORE' +CONTEXT: PL/Perl function "trigger_data" +delete from trigger_test; +NOTICE: $_TD->{argc} = '2' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{args} = ['23', 'skidoo'] +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{event} = 'DELETE' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{level} = 'ROW' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{name} = 'show_trigger_data_trig' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{old} = {'foo' => {'rfoo' => {'i' => '1'}}, 'i' => '1', 'v' => 'update'} +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relid} = 'bogus:12345' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{relname} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_name} = 'trigger_test' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{table_schema} = 'public' +CONTEXT: PL/Perl function "trigger_data" +NOTICE: $_TD->{when} = 'BEFORE' +CONTEXT: PL/Perl function "trigger_data" +DROP TRIGGER show_trigger_data_trig on 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; +ERROR: Cannot parallelize an UPDATE statement that updates the distribution columns +UPDATE trigger_test SET i = 100 where i=1; +ERROR: Cannot parallelize an UPDATE statement that updates the distribution columns +SELECT * FROM trigger_test; + i | v | foo +---+----------------------------------+--------- + 2 | second line(modified by trigger) | ("(3)") + 4 | immortal | ("(4)") + 1 | first line(modified by trigger) | ("(2)") + 3 | third line(modified by trigger) | ("(4)") +(4 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" http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperl_util.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out new file mode 100644 index 0000000..0996d2f --- /dev/null +++ b/src/pl/plperl/expected/plperl_util.out @@ -0,0 +1,167 @@ +-- test plperl utility functions (defined in Util.xs) +-- test quote_literal +create or replace function perl_quote_literal() returns setof text language plperl as $$ + return_next "undef: ".quote_literal(undef); + return_next sprintf"$_: ".quote_literal($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; +$$; +select perl_quote_literal(); + perl_quote_literal +-------------------- + undef: + foo: 'foo' + a'b: 'a''b' + a"b: 'a"b' + c''d: 'c''''d' + e\f: E'e\\f' + : '' +(7 rows) + +-- test quote_nullable +create or replace function perl_quote_nullable() returns setof text language plperl as $$ + return_next "undef: ".quote_nullable(undef); + return_next sprintf"$_: ".quote_nullable($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{}; + return undef; +$$; +select perl_quote_nullable(); + perl_quote_nullable +--------------------- + undef: NULL + foo: 'foo' + a'b: 'a''b' + a"b: 'a"b' + c''d: 'c''''d' + e\f: E'e\\f' + : '' +(7 rows) + +-- test quote_ident +create or replace function perl_quote_ident() returns setof text language plperl as $$ + return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled + return_next "$_: ".quote_ident($_) + for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{}; + return undef; +$$; +select perl_quote_ident(); + perl_quote_ident +------------------ + undef: "" + foo: foo + a'b: "a'b" + a"b: "a""b" + c''d: "c''d" + e\f: "e\f" + g.h: "g.h" + : "" +(8 rows) + +-- test decode_bytea +create or replace function perl_decode_bytea() returns setof text language plperl as $$ + return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled + return_next "$_: ".decode_bytea($_) + for q{foo}, q{a\047b}, q{}; + return undef; +$$; +select perl_decode_bytea(); + perl_decode_bytea +------------------- + undef: + foo: foo + a\047b: a'b + : +(4 rows) + +-- test encode_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[]); +ERROR: type "perl_foo[]" does not exist +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'); +$$; +select perl_encode_typed_literal(); +ERROR: type "perl_bar" does not exist +CONTEXT: PL/Perl function "perl_encode_typed_literal" http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/expected/plperlu.out ---------------------------------------------------------------------- diff --git a/src/pl/plperl/expected/plperlu.out b/src/pl/plperl/expected/plperlu.out new file mode 100644 index 0000000..6d2938a --- /dev/null +++ b/src/pl/plperl/expected/plperlu.out @@ -0,0 +1,13 @@ +-- Use ONLY plperlu tests here. For plperl/plerlu combined tests +-- see plperl_plperlu.sql +-- Avoid need for custom_variable_classes = 'plperl' +LOAD 'plperl'; +-- Test plperl.on_plperlu_init gets run +SET plperl.on_plperlu_init = '$_SHARED{init} = 42'; +-- +-- 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; http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/nls.mk ---------------------------------------------------------------------- diff --git a/src/pl/plperl/nls.mk b/src/pl/plperl/nls.mk new file mode 100755 index 0000000..bc6d1c3 --- /dev/null +++ b/src/pl/plperl/nls.mk @@ -0,0 +1,5 @@ +# $PostgreSQL: pgsql/src/pl/plperl/nls.mk,v 1.7.2.1 2009/09/03 21:01:21 petere Exp $ +CATALOG_NAME := plperl +AVAIL_LANGUAGES := de es fr it ja pt_BR tr +GETTEXT_FILES := plperl.c SPI.c +GETTEXT_TRIGGERS:= errmsg errmsg_plural:1,2 errdetail errdetail_log errdetail_plural:1,2 errhint errcontext http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plc_perlboot.pl ---------------------------------------------------------------------- diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl new file mode 100644 index 0000000..67c6560 --- /dev/null +++ b/src/pl/plperl/plc_perlboot.pl @@ -0,0 +1,105 @@ +# src/pl/plperl/plc_perlboot.pl + +use 5.008001; +use vars qw(%_SHARED); + +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]"; +} + +{ +package PostgreSQL::InServer; +use strict; +use warnings; + +sub plperl_warn { + (my $msg = shift) =~ s/\(eval \d+\) //g; + chomp $msg; + &::elog(&::WARNING, $msg); +} +$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 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; +} + +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; +} http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plc_trusted.pl ---------------------------------------------------------------------- diff --git a/src/pl/plperl/plc_trusted.pl b/src/pl/plperl/plc_trusted.pl new file mode 100644 index 0000000..cd61882 --- /dev/null +++ b/src/pl/plperl/plc_trusted.pl @@ -0,0 +1,27 @@ +# src/pl/plperl/plc_trusted.pl + +package PostgreSQL::InServer::safe; + +# 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; http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl--1.0.sql ---------------------------------------------------------------------- diff --git a/src/pl/plperl/plperl--1.0.sql b/src/pl/plperl/plperl--1.0.sql new file mode 100644 index 0000000..befd882 --- /dev/null +++ b/src/pl/plperl/plperl--1.0.sql @@ -0,0 +1,9 @@ +/* src/pl/plperl/plperl--1.0.sql */ + +/* + * Currently, all the interesting stuff is done by CREATE LANGUAGE. + * Later we will probably "dumb down" that command and put more of the + * knowledge into this script. + */ + +CREATE PROCEDURAL LANGUAGE plperl; http://git-wip-us.apache.org/repos/asf/incubator-hawq/blob/120ee70b/src/pl/plperl/plperl--unpackaged--1.0.sql ---------------------------------------------------------------------- diff --git a/src/pl/plperl/plperl--unpackaged--1.0.sql b/src/pl/plperl/plperl--unpackaged--1.0.sql new file mode 100644 index 0000000..b062bd5 --- /dev/null +++ b/src/pl/plperl/plperl--unpackaged--1.0.sql @@ -0,0 +1,7 @@ +/* src/pl/plperl/plperl--unpackaged--1.0.sql */ + +ALTER EXTENSION plperl ADD PROCEDURAL LANGUAGE plperl; +-- ALTER ADD LANGUAGE doesn't pick up the support functions, so we have to. +ALTER EXTENSION plperl ADD FUNCTION plperl_call_handler(); +ALTER EXTENSION plperl ADD FUNCTION plperl_inline_handler(internal); +ALTER EXTENSION plperl ADD FUNCTION plperl_validator(oid);
