Create contrib/bool_plperl to provide a bool transform for PL/Perl[U].

plperl's default handling of bool arguments or results is not terribly
satisfactory, since Perl doesn't consider the string 'f' to be false.
Ideally we'd just fix that, but the backwards-compatibility hazard
would be substantial.  Instead, build a TRANSFORM module that can
be optionally applied to provide saner semantics.

Perhaps usefully, this is also about the minimum possible skeletal
example of a plperl transform module; so it might be a better starting
point for user-written transform modules than hstore_plperl or
jsonb_plperl.

Ivan Panchenko

Discussion: https://postgr.es/m/1583013317.881182688@f390.i.mail.ru

11 files changed, 450 insertions, 0 deletions

diff --git a/contrib/bool_plperl/.gitignore b/contrib/bool_plperl/.gitignore
new file mode 100644
index 00000000000..5dcb3ff9723
--- /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 00000000000..efe1de986b2
--- /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 00000000000..00dc3b826f0
--- /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 00000000000..0fa1eee8e57
--- /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 00000000000..af3e6b1966f
--- /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 00000000000..52c55b6d5e2
--- /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 00000000000..d03a5843062
--- /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 00000000000..84c25acdb4f
--- /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 00000000000..745ba989338
--- /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 00000000000..dd99f545ea9
--- /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 00000000000..b756b0be676
--- /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;