From 36058a3c55d2c42a513a53da8140b07cf0893afb Mon Sep 17 00:00:00 2001 From: Tom Lane Date: Fri, 6 Mar 2020 17:11:23 -0500 Subject: [PATCH] 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 --- contrib/Makefile | 4 +- contrib/bool_plperl/.gitignore | 4 + contrib/bool_plperl/Makefile | 39 ++++++++ contrib/bool_plperl/bool_plperl--1.0.sql | 19 ++++ contrib/bool_plperl/bool_plperl.c | 30 ++++++ contrib/bool_plperl/bool_plperl.control | 7 ++ contrib/bool_plperl/bool_plperlu--1.0.sql | 19 ++++ contrib/bool_plperl/bool_plperlu.control | 6 ++ contrib/bool_plperl/expected/bool_plperl.out | 97 +++++++++++++++++++ contrib/bool_plperl/expected/bool_plperlu.out | 97 +++++++++++++++++++ contrib/bool_plperl/sql/bool_plperl.sql | 66 +++++++++++++ contrib/bool_plperl/sql/bool_plperlu.sql | 66 +++++++++++++ doc/src/sgml/plperl.sgml | 47 ++++++++- src/tools/msvc/Mkvcbuild.pm | 5 + 14 files changed, 502 insertions(+), 4 deletions(-) create mode 100644 contrib/bool_plperl/.gitignore create mode 100644 contrib/bool_plperl/Makefile create mode 100644 contrib/bool_plperl/bool_plperl--1.0.sql create mode 100644 contrib/bool_plperl/bool_plperl.c create mode 100644 contrib/bool_plperl/bool_plperl.control create mode 100644 contrib/bool_plperl/bool_plperlu--1.0.sql create mode 100644 contrib/bool_plperl/bool_plperlu.control create mode 100644 contrib/bool_plperl/expected/bool_plperl.out create mode 100644 contrib/bool_plperl/expected/bool_plperlu.out create mode 100644 contrib/bool_plperl/sql/bool_plperl.sql create mode 100644 contrib/bool_plperl/sql/bool_plperlu.sql 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); }