diff --git a/contrib/Makefile b/contrib/Makefile
index 92184ed487..1846d415b6 100644
--- a/contrib/Makefile
+++ b/contrib/Makefile
@@ -75,9 +75,9 @@ ALWAYS_SUBDIRS += sepgsql
endif
ifeq ($(with_perl),yes)
-SUBDIRS += hstore_plperl jsonb_plperl
+SUBDIRS += bool_plperl hstore_plperl jsonb_plperl
else
-ALWAYS_SUBDIRS += hstore_plperl jsonb_plperl
+ALWAYS_SUBDIRS += bool_plperl hstore_plperl jsonb_plperl
endif
ifeq ($(with_python),yes)
diff --git a/contrib/bool_plperl/.gitignore b/contrib/bool_plperl/.gitignore
new file mode 100644
index 0000000000..5dcb3ff972
--- /dev/null
+++ b/contrib/bool_plperl/.gitignore
@@ -0,0 +1,4 @@
+# Generated subdirectories
+/log/
+/results/
+/tmp_check/
diff --git a/contrib/bool_plperl/Makefile b/contrib/bool_plperl/Makefile
new file mode 100644
index 0000000000..efe1de986b
--- /dev/null
+++ b/contrib/bool_plperl/Makefile
@@ -0,0 +1,39 @@
+# contrib/bool_plperl/Makefile
+
+MODULE_big = bool_plperl
+OBJS = \
+ $(WIN32RES) \
+ bool_plperl.o
+PGFILEDESC = "bool_plperl - bool transform for plperl"
+
+PG_CPPFLAGS = -I$(top_srcdir)/src/pl/plperl
+
+EXTENSION = bool_plperlu bool_plperl
+DATA = bool_plperlu--1.0.sql bool_plperl--1.0.sql
+
+REGRESS = bool_plperl bool_plperlu
+
+ifdef USE_PGXS
+PG_CONFIG = pg_config
+PGXS := $(shell $(PG_CONFIG) --pgxs)
+include $(PGXS)
+else
+subdir = contrib/bool_plperl
+top_builddir = ../..
+include $(top_builddir)/src/Makefile.global
+include $(top_srcdir)/contrib/contrib-global.mk
+endif
+
+# We must link libperl explicitly
+ifeq ($(PORTNAME), win32)
+# these settings are the same as for plperl
+override CPPFLAGS += -DPLPERL_HAVE_UID_GID -Wno-comment
+# ... see silliness in plperl Makefile ...
+SHLIB_LINK_INTERNAL += $(sort $(wildcard ../../src/pl/plperl/libperl*.a))
+else
+rpathdir = $(perl_archlibexp)/CORE
+SHLIB_LINK += $(perl_embed_ldflags)
+endif
+
+# As with plperl we need to include the perl_includespec directory last.
+override CPPFLAGS := $(CPPFLAGS) $(perl_embed_ccflags) $(perl_includespec)
diff --git a/contrib/bool_plperl/bool_plperl--1.0.sql b/contrib/bool_plperl/bool_plperl--1.0.sql
new file mode 100644
index 0000000000..00dc3b826f
--- /dev/null
+++ b/contrib/bool_plperl/bool_plperl--1.0.sql
@@ -0,0 +1,19 @@
+/* contrib/bool_plperl/bool_plperl--1.0.sql */
+
+-- complain if script is sourced in psql, rather than via CREATE EXTENSION
+\echo Use "CREATE EXTENSION bool_plperl" to load this file. \quit
+
+CREATE FUNCTION bool_to_plperl(val internal) RETURNS internal
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME';
+
+CREATE FUNCTION plperl_to_bool(val internal) RETURNS bool
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME';
+
+CREATE TRANSFORM FOR bool LANGUAGE plperl (
+ FROM SQL WITH FUNCTION bool_to_plperl(internal),
+ TO SQL WITH FUNCTION plperl_to_bool(internal)
+);
+
+COMMENT ON TRANSFORM FOR bool LANGUAGE plperl IS 'transform between bool and Perl';
diff --git a/contrib/bool_plperl/bool_plperl.c b/contrib/bool_plperl/bool_plperl.c
new file mode 100644
index 0000000000..0fa1eee8e5
--- /dev/null
+++ b/contrib/bool_plperl/bool_plperl.c
@@ -0,0 +1,30 @@
+#include "postgres.h"
+
+#include "fmgr.h"
+#include "plperl.h"
+
+
+PG_MODULE_MAGIC;
+
+PG_FUNCTION_INFO_V1(bool_to_plperl);
+
+Datum
+bool_to_plperl(PG_FUNCTION_ARGS)
+{
+ dTHX;
+ bool in = PG_GETARG_BOOL(0);
+
+ return PointerGetDatum(in ? &PL_sv_yes : &PL_sv_no);
+}
+
+
+PG_FUNCTION_INFO_V1(plperl_to_bool);
+
+Datum
+plperl_to_bool(PG_FUNCTION_ARGS)
+{
+ dTHX;
+ SV *in = (SV *) PG_GETARG_POINTER(0);
+
+ PG_RETURN_BOOL(SvTRUE(in));
+}
diff --git a/contrib/bool_plperl/bool_plperl.control b/contrib/bool_plperl/bool_plperl.control
new file mode 100644
index 0000000000..af3e6b1966
--- /dev/null
+++ b/contrib/bool_plperl/bool_plperl.control
@@ -0,0 +1,7 @@
+# bool_plperl extension
+comment = 'transform between bool and plperl'
+default_version = '1.0'
+module_pathname = '$libdir/bool_plperl'
+relocatable = true
+trusted = true
+requires = 'plperl'
diff --git a/contrib/bool_plperl/bool_plperlu--1.0.sql b/contrib/bool_plperl/bool_plperlu--1.0.sql
new file mode 100644
index 0000000000..52c55b6d5e
--- /dev/null
+++ b/contrib/bool_plperl/bool_plperlu--1.0.sql
@@ -0,0 +1,19 @@
+/* contrib/bool_plperl/bool_plperlu--1.0.sql */
+
+-- complain if script is sourced in psql, rather than via CREATE EXTENSION
+\echo Use "CREATE EXTENSION bool_plperlu" to load this file. \quit
+
+CREATE FUNCTION bool_to_plperlu(val internal) RETURNS internal
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME', 'bool_to_plperl';
+
+CREATE FUNCTION plperlu_to_bool(val internal) RETURNS bool
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME', 'plperl_to_bool';
+
+CREATE TRANSFORM FOR bool LANGUAGE plperlu (
+ FROM SQL WITH FUNCTION bool_to_plperlu(internal),
+ TO SQL WITH FUNCTION plperlu_to_bool(internal)
+);
+
+COMMENT ON TRANSFORM FOR bool LANGUAGE plperlu IS 'transform between bool and Perl';
diff --git a/contrib/bool_plperl/bool_plperlu.control b/contrib/bool_plperl/bool_plperlu.control
new file mode 100644
index 0000000000..d03a584306
--- /dev/null
+++ b/contrib/bool_plperl/bool_plperlu.control
@@ -0,0 +1,6 @@
+# bool_plperlu extension
+comment = 'transform between bool and plperlu'
+default_version = '1.0'
+module_pathname = '$libdir/bool_plperl'
+relocatable = true
+requires = 'plperlu'
diff --git a/contrib/bool_plperl/expected/bool_plperl.out b/contrib/bool_plperl/expected/bool_plperl.out
new file mode 100644
index 0000000000..84c25acdb4
--- /dev/null
+++ b/contrib/bool_plperl/expected/bool_plperl.out
@@ -0,0 +1,97 @@
+CREATE EXTENSION bool_plperl CASCADE;
+NOTICE: installing required extension "plperl"
+--- test transforming from perl
+CREATE FUNCTION perl2int(int) RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+CREATE FUNCTION perl2text(text) RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+CREATE FUNCTION perl2undef() RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return undef;
+$$;
+SELECT perl2int(1);
+ perl2int
+----------
+ t
+(1 row)
+
+SELECT perl2int(0);
+ perl2int
+----------
+ f
+(1 row)
+
+SELECT perl2text('foo');
+ perl2text
+-----------
+ t
+(1 row)
+
+SELECT perl2text('');
+ perl2text
+-----------
+ f
+(1 row)
+
+SELECT perl2undef() IS NULL AS p;
+ p
+---
+ t
+(1 row)
+
+--- test transforming to perl
+CREATE FUNCTION bool2perl(bool, bool, bool) RETURNS void
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+my ($x, $y, $z) = @_;
+
+die("NULL mistransformed") if (defined($z));
+die("TRUE mistransformed to UNDEF") if (!defined($x));
+die("FALSE mistransformed to UNDEF") if (!defined($y));
+die("TRUE mistransformed") if (!$x);
+die("FALSE mistransformed") if ($y);
+$$;
+SELECT bool2perl (true, false, NULL);
+ bool2perl
+-----------
+
+(1 row)
+
+--- test selecting bool through SPI
+CREATE FUNCTION spi_test() RETURNS void
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+my $rv = spi_exec_query('SELECT true t, false f, NULL n')->{rows}->[0];
+
+die("TRUE mistransformed to UNDEF in SPI") if (!defined ($rv->{t}));
+die("FALSE mistransformed to UNDEF in SPI") if (!defined ($rv->{f}));
+die("NULL mistransformed in SPI") if (defined ($rv->{n}));
+die("TRUE mistransformed in SPI") if (!$rv->{t});
+die("FALSE mistransformed in SPI") if ($rv->{f});
+$$;
+SELECT spi_test();
+ spi_test
+----------
+
+(1 row)
+
+DROP EXTENSION plperl CASCADE;
+NOTICE: drop cascades to 6 other objects
+DETAIL: drop cascades to function spi_test()
+drop cascades to extension bool_plperl
+drop cascades to function perl2int(integer)
+drop cascades to function perl2text(text)
+drop cascades to function perl2undef()
+drop cascades to function bool2perl(boolean,boolean,boolean)
diff --git a/contrib/bool_plperl/expected/bool_plperlu.out b/contrib/bool_plperl/expected/bool_plperlu.out
new file mode 100644
index 0000000000..745ba98933
--- /dev/null
+++ b/contrib/bool_plperl/expected/bool_plperlu.out
@@ -0,0 +1,97 @@
+CREATE EXTENSION bool_plperlu CASCADE;
+NOTICE: installing required extension "plperlu"
+--- test transforming from perl
+CREATE FUNCTION perl2int(int) RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+CREATE FUNCTION perl2text(text) RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+CREATE FUNCTION perl2undef() RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return undef;
+$$;
+SELECT perl2int(1);
+ perl2int
+----------
+ t
+(1 row)
+
+SELECT perl2int(0);
+ perl2int
+----------
+ f
+(1 row)
+
+SELECT perl2text('foo');
+ perl2text
+-----------
+ t
+(1 row)
+
+SELECT perl2text('');
+ perl2text
+-----------
+ f
+(1 row)
+
+SELECT perl2undef() IS NULL AS p;
+ p
+---
+ t
+(1 row)
+
+--- test transforming to perl
+CREATE FUNCTION bool2perl(bool, bool, bool) RETURNS void
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+my ($x, $y, $z) = @_;
+
+die("NULL mistransformed") if (defined($z));
+die("TRUE mistransformed to UNDEF") if (!defined($x));
+die("FALSE mistransformed to UNDEF") if (!defined($y));
+die("TRUE mistransformed") if (!$x);
+die("FALSE mistransformed") if ($y);
+$$;
+SELECT bool2perl (true, false, NULL);
+ bool2perl
+-----------
+
+(1 row)
+
+--- test selecting bool through SPI
+CREATE FUNCTION spi_test() RETURNS void
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+my $rv = spi_exec_query('SELECT true t, false f, NULL n')->{rows}->[0];
+
+die("TRUE mistransformed to UNDEF in SPI") if (!defined ($rv->{t}));
+die("FALSE mistransformed to UNDEF in SPI") if (!defined ($rv->{f}));
+die("NULL mistransformed in SPI") if (defined ($rv->{n}));
+die("TRUE mistransformed in SPI") if (!$rv->{t});
+die("FALSE mistransformed in SPI") if ($rv->{f});
+$$;
+SELECT spi_test();
+ spi_test
+----------
+
+(1 row)
+
+DROP EXTENSION plperlu CASCADE;
+NOTICE: drop cascades to 6 other objects
+DETAIL: drop cascades to function spi_test()
+drop cascades to extension bool_plperlu
+drop cascades to function perl2int(integer)
+drop cascades to function perl2text(text)
+drop cascades to function perl2undef()
+drop cascades to function bool2perl(boolean,boolean,boolean)
diff --git a/contrib/bool_plperl/sql/bool_plperl.sql b/contrib/bool_plperl/sql/bool_plperl.sql
new file mode 100644
index 0000000000..dd99f545ea
--- /dev/null
+++ b/contrib/bool_plperl/sql/bool_plperl.sql
@@ -0,0 +1,66 @@
+CREATE EXTENSION bool_plperl CASCADE;
+
+--- test transforming from perl
+
+CREATE FUNCTION perl2int(int) RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+
+CREATE FUNCTION perl2text(text) RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+
+CREATE FUNCTION perl2undef() RETURNS bool
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+return undef;
+$$;
+
+SELECT perl2int(1);
+SELECT perl2int(0);
+SELECT perl2text('foo');
+SELECT perl2text('');
+SELECT perl2undef() IS NULL AS p;
+
+--- test transforming to perl
+
+CREATE FUNCTION bool2perl(bool, bool, bool) RETURNS void
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+my ($x, $y, $z) = @_;
+
+die("NULL mistransformed") if (defined($z));
+die("TRUE mistransformed to UNDEF") if (!defined($x));
+die("FALSE mistransformed to UNDEF") if (!defined($y));
+die("TRUE mistransformed") if (!$x);
+die("FALSE mistransformed") if ($y);
+$$;
+
+SELECT bool2perl (true, false, NULL);
+
+--- test selecting bool through SPI
+
+CREATE FUNCTION spi_test() RETURNS void
+LANGUAGE plperl
+TRANSFORM FOR TYPE bool
+AS $$
+my $rv = spi_exec_query('SELECT true t, false f, NULL n')->{rows}->[0];
+
+die("TRUE mistransformed to UNDEF in SPI") if (!defined ($rv->{t}));
+die("FALSE mistransformed to UNDEF in SPI") if (!defined ($rv->{f}));
+die("NULL mistransformed in SPI") if (defined ($rv->{n}));
+die("TRUE mistransformed in SPI") if (!$rv->{t});
+die("FALSE mistransformed in SPI") if ($rv->{f});
+$$;
+
+SELECT spi_test();
+
+DROP EXTENSION plperl CASCADE;
diff --git a/contrib/bool_plperl/sql/bool_plperlu.sql b/contrib/bool_plperl/sql/bool_plperlu.sql
new file mode 100644
index 0000000000..b756b0be67
--- /dev/null
+++ b/contrib/bool_plperl/sql/bool_plperlu.sql
@@ -0,0 +1,66 @@
+CREATE EXTENSION bool_plperlu CASCADE;
+
+--- test transforming from perl
+
+CREATE FUNCTION perl2int(int) RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+
+CREATE FUNCTION perl2text(text) RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return shift;
+$$;
+
+CREATE FUNCTION perl2undef() RETURNS bool
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+return undef;
+$$;
+
+SELECT perl2int(1);
+SELECT perl2int(0);
+SELECT perl2text('foo');
+SELECT perl2text('');
+SELECT perl2undef() IS NULL AS p;
+
+--- test transforming to perl
+
+CREATE FUNCTION bool2perl(bool, bool, bool) RETURNS void
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+my ($x, $y, $z) = @_;
+
+die("NULL mistransformed") if (defined($z));
+die("TRUE mistransformed to UNDEF") if (!defined($x));
+die("FALSE mistransformed to UNDEF") if (!defined($y));
+die("TRUE mistransformed") if (!$x);
+die("FALSE mistransformed") if ($y);
+$$;
+
+SELECT bool2perl (true, false, NULL);
+
+--- test selecting bool through SPI
+
+CREATE FUNCTION spi_test() RETURNS void
+LANGUAGE plperlu
+TRANSFORM FOR TYPE bool
+AS $$
+my $rv = spi_exec_query('SELECT true t, false f, NULL n')->{rows}->[0];
+
+die("TRUE mistransformed to UNDEF in SPI") if (!defined ($rv->{t}));
+die("FALSE mistransformed to UNDEF in SPI") if (!defined ($rv->{f}));
+die("NULL mistransformed in SPI") if (defined ($rv->{n}));
+die("TRUE mistransformed in SPI") if (!$rv->{t});
+die("FALSE mistransformed in SPI") if ($rv->{f});
+$$;
+
+SELECT spi_test();
+
+DROP EXTENSION plperlu CASCADE;
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index e4769c0e38..033ed6960c 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -55,8 +55,11 @@
syntax:
-CREATE FUNCTION funcname (argument-types) RETURNS return-type AS $$
- # PL/Perl function body
+CREATE FUNCTION funcname (argument-types)
+RETURNS return-type
+-- function attributes can go here
+AS $$
+ # PL/Perl function body goes here
$$ LANGUAGE plperl;
@@ -188,6 +191,39 @@ $$ LANGUAGE plperl;
escape binary data for a return value of type bytea.
+
+ One case that is particularly important is boolean values. As just
+ stated, the default behavior for bool values is that they
+ are passed to Perl as text, thus either 't'
+ or 'f'. This is problematic, since Perl will not
+ treat 'f' as false! It is possible to improve matters
+ by using a transform
(see
+ ). Suitable transforms are provided
+ by the bool_plperl extension. To use it, install
+ the extension:
+
+CREATE EXTENSION bool_plperl; -- or bool_plperlu for PL/PerlU
+
+ Then use the TRANSFORM function attribute for a
+ PL/Perl function that takes or returns bool, for example:
+
+CREATE FUNCTION perl_and(bool, bool) RETURNS bool
+TRANSFORM FOR TYPE bool
+AS $$
+ my ($a, $b) = @_;
+ return $a && $b;
+$$ LANGUAGE plperl;
+
+ When this transform is applied, bool arguments will be seen
+ by Perl as being 1 or empty, thus properly true or
+ false. If the function result is type bool, it will be true
+ or false according to whether Perl would evaluate the returned value as
+ true.
+ Similar transformations are also performed for boolean query arguments
+ and results of SPI queries performed inside the function
+ ().
+
+
Perl can return PostgreSQL arrays as
references to Perl arrays. Here is an example:
@@ -382,6 +418,13 @@ use strict;
commands will accept any string that is acceptable input format
for the function's declared return type.
+
+
+ If this behavior is inconvenient for a particular case, it can be
+ improved by using a transform, as already illustrated
+ for bool values. Several examples of transform modules
+ are included in the PostgreSQL distribution.
+
diff --git a/src/tools/msvc/Mkvcbuild.pm b/src/tools/msvc/Mkvcbuild.pm
index ec25042933..f89a8a4fdb 100644
--- a/src/tools/msvc/Mkvcbuild.pm
+++ b/src/tools/msvc/Mkvcbuild.pm
@@ -43,6 +43,7 @@ my $contrib_extrasource = {
'seg' => [ 'contrib/seg/segscan.l', 'contrib/seg/segparse.y' ],
};
my @contrib_excludes = (
+ 'bool_plperl',
'commit_ts', 'hstore_plperl',
'hstore_plpython', 'intagg',
'jsonb_plperl', 'jsonb_plpython',
@@ -763,6 +764,9 @@ sub mkvcbuild
}
# Add transform modules dependent on plperl
+ my $bool_plperl = AddTransformModule(
+ 'bool_plperl', 'contrib/bool_plperl',
+ 'plperl', 'src/pl/plperl');
my $hstore_plperl = AddTransformModule(
'hstore_plperl', 'contrib/hstore_plperl',
'plperl', 'src/pl/plperl',
@@ -773,6 +777,7 @@ sub mkvcbuild
foreach my $f (@perl_embed_ccflags)
{
+ $bool_plperl->AddDefine($f);
$hstore_plperl->AddDefine($f);
$jsonb_plperl->AddDefine($f);
}