hawq-commits mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From h...@apache.org
Subject [5/5] incubator-hawq git commit: HAWQ-744. Add plperl code
Date Fri, 20 May 2016 10:21:09 GMT
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 <paulguo@gmail.com>
Authored: Thu May 19 18:41:12 2016 +0800
Committer: Ruilong Huo <rhuo@pivotal.io>
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);


Mime
View raw message