Re: Bytea PL/Perl transform

Pavel Stehule <pavel.stehule@gmail.com> writes:

> I inserted perl reference support - hstore_plperl and json_plperl does it.
>
> +<->/* Dereference references recursively. */
> +<->while (SvROK(in))
> +<-><-->in = SvRV(in);

That code in hstore_plperl and json_plperl is only relevant because they
deal with non-scalar values (hashes for hstore, and also arrays for
json) which must be passed as references.  The recursive nature of the
dereferencing is questionable, and masked the bug fixed by commit
1731e3741cbbf8e0b4481665d7d523bc55117f63.

bytea_plperl only deals with scalars (specifically strings), so should
not concern itself with references.  In fact, this code breaks returning
objects with overloaded stringification, for example:

CREATE FUNCTION plperlu_overload() RETURNS bytea LANGUAGE plperlu
  TRANSFORM FOR TYPE bytea
  AS $$
    package StringOverload { use overload '""' => sub { "stuff" }; }
    return bless {}, "StringOverload";
  $$;

This makes the server crash with an assertion failure from Perl because
SvPVbyte() was passed a non-scalar value:

postgres: ilmari regression_bytea_plperl [local] SELECT: sv.c:2865: Perl_sv_2pv_flags:
Assertion `SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM' failed.

If I remove the dereferincing loop it succeeds:

SELECT encode(plperlu_overload(), 'escape') AS string;
 string
--------
 stuff
(1 row)

Attached is a v2 patch which removes the dereferencing and includes the
above example as a test.

- ilmari

From aabaf4f5932f59de2fed48bbba7339807a1f04bd Mon Sep 17 00:00:00 2001
From: "okbob@github.com" <okbob@github.com>
Date: Tue, 30 Jan 2024 10:31:00 +0100
Subject: [PATCH v2] Add bytea transformation for plperl

---
 contrib/Makefile                              |  4 +-
 contrib/bytea_plperl/.gitignore               |  4 ++
 contrib/bytea_plperl/Makefile                 | 39 ++++++++++++++
 contrib/bytea_plperl/bytea_plperl--1.0.sql    | 19 +++++++
 contrib/bytea_plperl/bytea_plperl.c           | 44 ++++++++++++++++
 contrib/bytea_plperl/bytea_plperl.control     |  7 +++
 contrib/bytea_plperl/bytea_plperlu--1.0.sql   | 19 +++++++
 contrib/bytea_plperl/bytea_plperlu.control    |  6 +++
 .../bytea_plperl/expected/bytea_plperl.out    | 49 ++++++++++++++++++
 .../bytea_plperl/expected/bytea_plperlu.out   | 49 ++++++++++++++++++
 contrib/bytea_plperl/meson.build              | 51 +++++++++++++++++++
 contrib/bytea_plperl/sql/bytea_plperl.sql     | 31 +++++++++++
 contrib/bytea_plperl/sql/bytea_plperlu.sql    | 31 +++++++++++
 contrib/meson.build                           |  1 +
 doc/src/sgml/plperl.sgml                      | 16 ++++++
 15 files changed, 368 insertions(+), 2 deletions(-)
 create mode 100644 contrib/bytea_plperl/.gitignore
 create mode 100644 contrib/bytea_plperl/Makefile
 create mode 100644 contrib/bytea_plperl/bytea_plperl--1.0.sql
 create mode 100644 contrib/bytea_plperl/bytea_plperl.c
 create mode 100644 contrib/bytea_plperl/bytea_plperl.control
 create mode 100644 contrib/bytea_plperl/bytea_plperlu--1.0.sql
 create mode 100644 contrib/bytea_plperl/bytea_plperlu.control
 create mode 100644 contrib/bytea_plperl/expected/bytea_plperl.out
 create mode 100644 contrib/bytea_plperl/expected/bytea_plperlu.out
 create mode 100644 contrib/bytea_plperl/meson.build
 create mode 100644 contrib/bytea_plperl/sql/bytea_plperl.sql
 create mode 100644 contrib/bytea_plperl/sql/bytea_plperlu.sql

diff --git a/contrib/Makefile b/contrib/Makefile
index da4e2316a3..56c628df00 100644
--- a/contrib/Makefile
+++ b/contrib/Makefile
@@ -77,9 +77,9 @@ ALWAYS_SUBDIRS += sepgsql
 endif
 
 ifeq ($(with_perl),yes)
-SUBDIRS += bool_plperl hstore_plperl jsonb_plperl
+SUBDIRS += bool_plperl bytea_plperl hstore_plperl jsonb_plperl
 else
-ALWAYS_SUBDIRS += bool_plperl hstore_plperl jsonb_plperl
+ALWAYS_SUBDIRS += bool_plperl bytea_plperl hstore_plperl jsonb_plperl
 endif
 
 ifeq ($(with_python),yes)
diff --git a/contrib/bytea_plperl/.gitignore b/contrib/bytea_plperl/.gitignore
new file mode 100644
index 0000000000..5dcb3ff972
--- /dev/null
+++ b/contrib/bytea_plperl/.gitignore
@@ -0,0 +1,4 @@
+# Generated subdirectories
+/log/
+/results/
+/tmp_check/
diff --git a/contrib/bytea_plperl/Makefile b/contrib/bytea_plperl/Makefile
new file mode 100644
index 0000000000..1814d2f418
--- /dev/null
+++ b/contrib/bytea_plperl/Makefile
@@ -0,0 +1,39 @@
+# contrib/bytea_plperl/Makefile
+
+MODULE_big = bytea_plperl
+OBJS = \
+    $(WIN32RES) \
+    bytea_plperl.o
+PGFILEDESC = "bytea_plperl - bytea transform for plperl"
+
+PG_CPPFLAGS = -I$(top_srcdir)/src/pl/plperl
+
+EXTENSION = bytea_plperlu bytea_plperl
+DATA = bytea_plperlu--1.0.sql bytea_plperl--1.0.sql
+
+REGRESS = bytea_plperl bytea_plperlu
+
+ifdef USE_PGXS
+PG_CONFIG = pg_config
+PGXS := $(shell $(PG_CONFIG) --pgxs)
+include $(PGXS)
+else
+subdir = contrib/bytea_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/bytea_plperl/bytea_plperl--1.0.sql b/contrib/bytea_plperl/bytea_plperl--1.0.sql
new file mode 100644
index 0000000000..6544b2ac85
--- /dev/null
+++ b/contrib/bytea_plperl/bytea_plperl--1.0.sql
@@ -0,0 +1,19 @@
+/* contrib/bytea_plperl/bytea_plperl--1.0.sql */
+
+-- complain if script is sourced in psql, rather than via CREATE EXTENSION
+\echo Use "CREATE EXTENSION bytea_plperl" to load this file. \quit
+
+CREATE FUNCTION bytea_to_plperl(val internal) RETURNS internal
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME';
+
+CREATE FUNCTION plperl_to_bytea(val internal) RETURNS bytea
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME';
+
+CREATE TRANSFORM FOR bytea LANGUAGE plperl (
+    FROM SQL WITH FUNCTION bytea_to_plperl(internal),
+    TO SQL WITH FUNCTION plperl_to_bytea(internal)
+);
+
+COMMENT ON TRANSFORM FOR bytea LANGUAGE plperl IS 'transform between bytea and Perl';
diff --git a/contrib/bytea_plperl/bytea_plperl.c b/contrib/bytea_plperl/bytea_plperl.c
new file mode 100644
index 0000000000..5a0c58d8ab
--- /dev/null
+++ b/contrib/bytea_plperl/bytea_plperl.c
@@ -0,0 +1,44 @@
+/*
+ * contrib/bytea_plperl/bytea_plperl.c
+ */
+
+#include "postgres.h"
+
+#include "fmgr.h"
+#include "plperl.h"
+#include "varatt.h"
+
+PG_MODULE_MAGIC;
+
+PG_FUNCTION_INFO_V1(bytea_to_plperl);
+PG_FUNCTION_INFO_V1(plperl_to_bytea);
+
+Datum
+bytea_to_plperl(PG_FUNCTION_ARGS)
+{
+    dTHX;
+    bytea       *in = PG_GETARG_BYTEA_PP(0);
+
+    return PointerGetDatum(newSVpvn_flags((char *) VARDATA_ANY(in),
+                                          VARSIZE_ANY_EXHDR(in), 0 ));
+}
+
+Datum
+plperl_to_bytea(PG_FUNCTION_ARGS)
+{
+    dTHX;
+    bytea       *result;
+    STRLEN        len;
+    char       *ptr;
+    SV           *in;
+
+    in = (SV *) PG_GETARG_POINTER(0);
+
+    ptr = SvPVbyte(in, len);
+
+    result = palloc(VARHDRSZ + len );
+    SET_VARSIZE(result, VARHDRSZ + len );
+    memcpy(VARDATA_ANY(result), ptr,len );
+
+    PG_RETURN_BYTEA_P(result);
+}
diff --git a/contrib/bytea_plperl/bytea_plperl.control b/contrib/bytea_plperl/bytea_plperl.control
new file mode 100644
index 0000000000..9ff0f2a8dd
--- /dev/null
+++ b/contrib/bytea_plperl/bytea_plperl.control
@@ -0,0 +1,7 @@
+# bytea_plperl extension
+comment = 'transform between bytea and plperl'
+default_version = '1.0'
+module_pathname = '$libdir/bytea_plperl'
+relocatable = true
+trusted = true
+requires = 'plperl'
diff --git a/contrib/bytea_plperl/bytea_plperlu--1.0.sql b/contrib/bytea_plperl/bytea_plperlu--1.0.sql
new file mode 100644
index 0000000000..d43e8fbaf4
--- /dev/null
+++ b/contrib/bytea_plperl/bytea_plperlu--1.0.sql
@@ -0,0 +1,19 @@
+/* contrib/bytea_plperl/bytea_plperlu--1.0.sql */
+
+-- complain if script is sourced in psql, rather than via CREATE EXTENSION
+\echo Use "CREATE EXTENSION bytea_plperlu" to load this file. \quit
+
+CREATE FUNCTION bytea_to_plperlu(val internal) RETURNS internal
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME', 'bytea_to_plperl';
+
+CREATE FUNCTION plperlu_to_bytea(val internal) RETURNS bytea
+LANGUAGE C STRICT IMMUTABLE
+AS 'MODULE_PATHNAME', 'plperl_to_bytea';
+
+CREATE TRANSFORM FOR bytea LANGUAGE plperlu (
+    FROM SQL WITH FUNCTION bytea_to_plperlu(internal),
+    TO SQL WITH FUNCTION plperlu_to_bytea(internal)
+);
+
+COMMENT ON TRANSFORM FOR bytea LANGUAGE plperlu IS 'transform between bytea and Perl';
diff --git a/contrib/bytea_plperl/bytea_plperlu.control b/contrib/bytea_plperl/bytea_plperlu.control
new file mode 100644
index 0000000000..96cc8c35fb
--- /dev/null
+++ b/contrib/bytea_plperl/bytea_plperlu.control
@@ -0,0 +1,6 @@
+# bytea_plperlu extension
+comment = 'transform between bytea and plperlu'
+default_version = '1.0'
+module_pathname = '$libdir/bytea_plperl'
+relocatable = true
+requires = 'plperlu'
diff --git a/contrib/bytea_plperl/expected/bytea_plperl.out b/contrib/bytea_plperl/expected/bytea_plperl.out
new file mode 100644
index 0000000000..99fe3aadce
--- /dev/null
+++ b/contrib/bytea_plperl/expected/bytea_plperl.out
@@ -0,0 +1,49 @@
+CREATE EXTENSION bytea_plperl CASCADE;
+NOTICE:  installing required extension "plperl"
+CREATE FUNCTION cat_bytea(bytea) RETURNS bytea LANGUAGE plperl
+ TRANSFORM FOR TYPE bytea
+ AS $$
+    return $_[0];
+ $$;
+SELECT data = cat_bytea(data)
+    FROM (
+        SELECT decode(repeat(unnest(ARRAY[ 'a','abc', 'abcd', 'abcdefgh\000ijkl12' , '爱' ]), 10000), 'escape') data
+    ) line;
+ ?column? 
+----------
+ t
+ t
+ t
+ t
+ t
+(5 rows)
+
+CREATE FUNCTION perl_inverse_bytes(bytea) RETURNS bytea
+TRANSFORM FOR TYPE bytea
+AS $$
+    return join '', reverse split('', $_[0]);
+$$ LANGUAGE plperl;
+SELECT 'ξενία'::bytea, perl_inverse_bytes('ξενία'::bytea);
+         bytea          |   perl_inverse_bytes   
+------------------------+------------------------
+ \xcebeceb5cebdceafceb1 | \xb1ceafcebdceb5cebece
+(1 row)
+
+CREATE FUNCTION plperl_bytea_overload() RETURNS bytea LANGUAGE plperl
+ TRANSFORM FOR TYPE bytea
+ AS $$
+   package StringOverload { use overload '""' => sub { "stuff" }; }
+   return bless {}, "StringOverload";
+ $$;
+SELECT encode(plperl_bytea_overload(), 'escape') string;
+ string 
+--------
+ stuff
+(1 row)
+
+DROP EXTENSION plperl CASCADE;
+NOTICE:  drop cascades to 4 other objects
+DETAIL:  drop cascades to extension bytea_plperl
+drop cascades to function cat_bytea(bytea)
+drop cascades to function perl_inverse_bytes(bytea)
+drop cascades to function plperl_bytea_overload()
diff --git a/contrib/bytea_plperl/expected/bytea_plperlu.out b/contrib/bytea_plperl/expected/bytea_plperlu.out
new file mode 100644
index 0000000000..6402685036
--- /dev/null
+++ b/contrib/bytea_plperl/expected/bytea_plperlu.out
@@ -0,0 +1,49 @@
+CREATE EXTENSION bytea_plperlu CASCADE;
+NOTICE:  installing required extension "plperlu"
+CREATE FUNCTION cat_bytea(bytea) RETURNS bytea LANGUAGE plperlu
+ TRANSFORM FOR TYPE bytea
+ AS $$
+    return $_[0];
+ $$;
+SELECT data = cat_bytea(data)
+    FROM (
+        SELECT decode(repeat(unnest(ARRAY[ 'a','abc', 'abcd', 'abcdefgh\000ijkl12' , '爱' ]), 10000), 'escape') data
+    ) line;
+ ?column? 
+----------
+ t
+ t
+ t
+ t
+ t
+(5 rows)
+
+CREATE FUNCTION perlu_inverse_bytes(bytea) RETURNS bytea
+TRANSFORM FOR TYPE bytea
+AS $$
+    return join '', reverse split('', $_[0]);
+$$ LANGUAGE plperlu;
+SELECT 'ξενία'::bytea, perlu_inverse_bytes('ξενία'::bytea);
+         bytea          |  perlu_inverse_bytes   
+------------------------+------------------------
+ \xcebeceb5cebdceafceb1 | \xb1ceafcebdceb5cebece
+(1 row)
+
+CREATE FUNCTION plperlu_bytea_overload() RETURNS bytea LANGUAGE plperlu
+ TRANSFORM FOR TYPE bytea
+ AS $$
+   package StringOverload { use overload '""' => sub { "stuff" }; }
+   return bless {}, "StringOverload";
+ $$;
+SELECT encode(plperlu_bytea_overload(), 'escape') string;
+ string 
+--------
+ stuff
+(1 row)
+
+DROP EXTENSION plperlu CASCADE;
+NOTICE:  drop cascades to 4 other objects
+DETAIL:  drop cascades to extension bytea_plperlu
+drop cascades to function cat_bytea(bytea)
+drop cascades to function perlu_inverse_bytes(bytea)
+drop cascades to function plperlu_bytea_overload()
diff --git a/contrib/bytea_plperl/meson.build b/contrib/bytea_plperl/meson.build
new file mode 100644
index 0000000000..3c438c2175
--- /dev/null
+++ b/contrib/bytea_plperl/meson.build
@@ -0,0 +1,51 @@
+# Copyright (c) 2023, PostgreSQL Global Development Group
+
+if not perl_dep.found()
+  subdir_done()
+endif
+
+bytea_plperl_sources = files(
+  'bytea_plperl.c',
+)
+
+if host_system == 'windows'
+  bytea_plperl_sources += rc_lib_gen.process(win32ver_rc, extra_args: [
+    '--NAME', 'bytea_plperl',
+    '--FILEDESC', 'bytea_plperl - bytea transform for plperl',])
+endif
+
+bytea_plperl = shared_module('bytea_plperl',
+  bytea_plperl_sources,
+  include_directories: [plperl_inc],
+  kwargs: contrib_mod_args + {
+    'dependencies': [perl_dep, contrib_mod_args['dependencies']],
+    'install_rpath': ':'.join(mod_install_rpaths + ['@0@/CORE'.format(archlibexp)]),
+    'build_rpath': '@0@/CORE'.format(archlibexp),
+  },
+)
+contrib_targets += bytea_plperl
+
+install_data(
+  'bytea_plperl.control',
+  'bytea_plperl--1.0.sql',
+  kwargs: contrib_data_args,
+)
+
+install_data(
+  'bytea_plperlu.control',
+  'bytea_plperlu--1.0.sql',
+  kwargs: contrib_data_args,
+)
+
+
+tests += {
+  'name': 'bytea_plperl',
+  'sd': meson.current_source_dir(),
+  'bd': meson.current_build_dir(),
+  'regress': {
+    'sql': [
+      'bytea_plperl',
+      'bytea_plperlu',
+    ],
+  },
+}
diff --git a/contrib/bytea_plperl/sql/bytea_plperl.sql b/contrib/bytea_plperl/sql/bytea_plperl.sql
new file mode 100644
index 0000000000..0836290244
--- /dev/null
+++ b/contrib/bytea_plperl/sql/bytea_plperl.sql
@@ -0,0 +1,31 @@
+CREATE EXTENSION bytea_plperl CASCADE;
+
+CREATE FUNCTION cat_bytea(bytea) RETURNS bytea LANGUAGE plperl
+ TRANSFORM FOR TYPE bytea
+ AS $$
+    return $_[0];
+ $$;
+
+SELECT data = cat_bytea(data)
+    FROM (
+        SELECT decode(repeat(unnest(ARRAY[ 'a','abc', 'abcd', 'abcdefgh\000ijkl12' , '爱' ]), 10000), 'escape') data
+    ) line;
+
+CREATE FUNCTION perl_inverse_bytes(bytea) RETURNS bytea
+TRANSFORM FOR TYPE bytea
+AS $$
+    return join '', reverse split('', $_[0]);
+$$ LANGUAGE plperl;
+
+SELECT 'ξενία'::bytea, perl_inverse_bytes('ξενία'::bytea);
+
+CREATE FUNCTION plperl_bytea_overload() RETURNS bytea LANGUAGE plperl
+ TRANSFORM FOR TYPE bytea
+ AS $$
+   package StringOverload { use overload '""' => sub { "stuff" }; }
+   return bless {}, "StringOverload";
+ $$;
+
+SELECT encode(plperl_bytea_overload(), 'escape') string;
+
+DROP EXTENSION plperl CASCADE;
diff --git a/contrib/bytea_plperl/sql/bytea_plperlu.sql b/contrib/bytea_plperl/sql/bytea_plperlu.sql
new file mode 100644
index 0000000000..4bbd697f32
--- /dev/null
+++ b/contrib/bytea_plperl/sql/bytea_plperlu.sql
@@ -0,0 +1,31 @@
+CREATE EXTENSION bytea_plperlu CASCADE;
+
+CREATE FUNCTION cat_bytea(bytea) RETURNS bytea LANGUAGE plperlu
+ TRANSFORM FOR TYPE bytea
+ AS $$
+    return $_[0];
+ $$;
+
+SELECT data = cat_bytea(data)
+    FROM (
+        SELECT decode(repeat(unnest(ARRAY[ 'a','abc', 'abcd', 'abcdefgh\000ijkl12' , '爱' ]), 10000), 'escape') data
+    ) line;
+
+CREATE FUNCTION perlu_inverse_bytes(bytea) RETURNS bytea
+TRANSFORM FOR TYPE bytea
+AS $$
+    return join '', reverse split('', $_[0]);
+$$ LANGUAGE plperlu;
+
+SELECT 'ξενία'::bytea, perlu_inverse_bytes('ξενία'::bytea);
+
+CREATE FUNCTION plperlu_bytea_overload() RETURNS bytea LANGUAGE plperlu
+ TRANSFORM FOR TYPE bytea
+ AS $$
+   package StringOverload { use overload '""' => sub { "stuff" }; }
+   return bless {}, "StringOverload";
+ $$;
+
+SELECT encode(plperlu_bytea_overload(), 'escape') string;
+
+DROP EXTENSION plperlu CASCADE;
diff --git a/contrib/meson.build b/contrib/meson.build
index c12dc906ca..7fe53fafeb 100644
--- a/contrib/meson.build
+++ b/contrib/meson.build
@@ -22,6 +22,7 @@ subdir('basebackup_to_shell')
 subdir('bool_plperl')
 subdir('btree_gin')
 subdir('btree_gist')
+subdir('bytea_plperl')
 subdir('citext')
 subdir('cube')
 subdir('dblink')
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 25b1077ad7..eea293eaec 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -224,6 +224,22 @@
    (<xref linkend="plperl-database"/>).
   </para>
 
+  <para>
+   Normally the <type>bytea</type> arguments are seen by Perl as strings in hex format (see
+   <xref linkend="datatype-binary"/>).
+   If the transform defined by the <filename>bytea_plperl</filename> extension is used, they are
+   passed and returned as native Perl octet strings, see example below:
+<programlisting>
+CREATE EXTENSION bytea_plperl; -- or bool_plperlu for PL/PerlU
+CREATE FUNCTION perl_inverse_bytes(bytea) RETURNS bytea
+TRANSFORM FOR TYPE bytea
+AS $$
+    return join '', reverse split('', $_[0]);
+$$ LANGUAGE plperl;
+</programlisting>
+
+  </para>
+
   <para>
    Perl can return <productname>PostgreSQL</productname> arrays as
    references to Perl arrays.  Here is an example:
-- 
2.39.2