postgres.git / summary / log / commit / refs
commit ccab6d36d0cbe554c380f69ade1598a41c06552a
Author: Tom Lane <tgl@sss.pgh.pa.us>
Date: Wed Aug 19 18:06:52 2026 +0000
Support tied Perl objects in plperl and associated contrib modules.
Up to now, if you passed a "tied" object to a PL/Perl operation,
it would most likely get treated as "undef", since we failed to
perform get magic on values we're passed. Tied hashes worked
partially, in that you could read out their keys, but the values
always read as undef.
To fix, use hv_iterval() not HeVAL() to fetch values from perl
hashes, and be careful to apply plperl_materialize_sv() before
testing SvOK() or SvROK() on any perl SV.
Add regression test cases exercising some typical usage scenarios
for tied objects.
Arguably this is a bug fix, but in view of the lack of field
complaints to date, let's treat it as a new feature instead.
The risk/reward ratio for back-patching isn't attractive.
Author: Andrey Rachitskiy <pl0h0yp1@gmail.com>
Reviewed-by: Tom Lane <tgl@sss.pgh.pa.us>
Discussion: https://postgr.es/m/569769.1786901901@sss.pgh.pa.us
contrib/hstore_plperl/expected/hstore_plperl.out | 25 +++++
contrib/hstore_plperl/hstore_plperl.c | 10 +-
contrib/hstore_plperl/sql/hstore_plperl.sql | 22 ++++
contrib/jsonb_plperl/expected/jsonb_plperl.out | 46 +++++++-
contrib/jsonb_plperl/jsonb_plperl.c | 4 +-
contrib/jsonb_plperl/sql/jsonb_plperl.sql | 39 +++++++
src/pl/plperl/GNUmakefile | 2 +-
src/pl/plperl/expected/plperl_tied.out | 132 +++++++++++++++++++++++
src/pl/plperl/meson.build | 1 +
src/pl/plperl/plperl.c | 44 ++++++--
src/pl/plperl/plperl.h | 10 ++
src/pl/plperl/sql/plperl_tied.sql | 113 +++++++++++++++++++
12 files changed, 431 insertions(+), 17 deletions(-)
diff --git a/contrib/hstore_plperl/expected/hstore_plperl.out b/contrib/hstore_plperl/expected/hstore_plperl.out
index 1ab09a94cda..e64ad98c38d 100644
--- a/contrib/hstore_plperl/expected/hstore_plperl.out
+++ b/contrib/hstore_plperl/expected/hstore_plperl.out
@@ -60,8 +60,33 @@ $$;
SELECT test2();
ERROR: cannot transform non-hash Perl value to hstore
CONTEXT: PL/Perl function "test2"
+-- test with a tied hash
+CREATE FUNCTION tied_hstore() RETURNS hstore
+LANGUAGE plperl
+TRANSFORM FOR TYPE hstore
+AS $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+}
+my %h;
+tie %h, 'PLPerlTiedHash';
+$h{a} = '1'; $h{b} = '2'; $h{c} = undef;
+return \%h;
+$$;
+SELECT tied_hstore();
+ tied_hstore
+-------------------------------
+ "a"=>"1", "b"=>"2", "c"=>NULL
+(1 row)
+
DROP FUNCTION test2();
DROP FUNCTION test2arr();
+DROP FUNCTION tied_hstore();
DROP EXTENSION hstore_plperl;
DROP EXTENSION hstore;
DROP EXTENSION plperl;
diff --git a/contrib/hstore_plperl/hstore_plperl.c b/contrib/hstore_plperl/hstore_plperl.c
index 5d2c4e85d21..d3565c1ce7a 100644
--- a/contrib/hstore_plperl/hstore_plperl.c
+++ b/contrib/hstore_plperl/hstore_plperl.c
@@ -111,7 +111,8 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
Pairs *pairs;
/* Dereference references recursively. */
- while (SvROK(in))
+ plperl_materialize_sv(in);
+ while (in && SvROK(in))
{
/*
* It's possible for circular references to make this an infinite
@@ -120,10 +121,11 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
*/
CHECK_FOR_INTERRUPTS();
in = SvRV(in);
+ plperl_materialize_sv(in);
}
/* Now we must have a hash. */
- if (SvTYPE(in) != SVt_PVHV)
+ if (!in || SvTYPE(in) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
errmsg("cannot transform non-hash Perl value to hstore")));
@@ -138,7 +140,9 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
while ((he = hv_iternext(hv)))
{
char *key = hek2cstr(he);
- SV *value = HeVAL(he);
+ SV *value = hv_iterval(hv, he);
+
+ plperl_materialize_sv(value);
if (i >= pcount)
{
diff --git a/contrib/hstore_plperl/sql/hstore_plperl.sql b/contrib/hstore_plperl/sql/hstore_plperl.sql
index ad1db7eae17..f1220a3baf2 100644
--- a/contrib/hstore_plperl/sql/hstore_plperl.sql
+++ b/contrib/hstore_plperl/sql/hstore_plperl.sql
@@ -50,9 +50,31 @@ $$;
SELECT test2();
+-- test with a tied hash
+CREATE FUNCTION tied_hstore() RETURNS hstore
+LANGUAGE plperl
+TRANSFORM FOR TYPE hstore
+AS $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+}
+my %h;
+tie %h, 'PLPerlTiedHash';
+$h{a} = '1'; $h{b} = '2'; $h{c} = undef;
+return \%h;
+$$;
+
+SELECT tied_hstore();
+
DROP FUNCTION test2();
DROP FUNCTION test2arr();
+DROP FUNCTION tied_hstore();
DROP EXTENSION hstore_plperl;
diff --git a/contrib/jsonb_plperl/expected/jsonb_plperl.out b/contrib/jsonb_plperl/expected/jsonb_plperl.out
index 5a73485ac06..2d61a9826f0 100644
--- a/contrib/jsonb_plperl/expected/jsonb_plperl.out
+++ b/contrib/jsonb_plperl/expected/jsonb_plperl.out
@@ -53,6 +53,50 @@ SELECT testUVToJsonb() IN ('18446744073709551615'::jsonb, '4294967295'::jsonb);
t
(1 row)
+-- test tied hash and array cases
+CREATE FUNCTION tied_jsonb_hash() RETURNS jsonb
+LANGUAGE plperl
+TRANSFORM FOR TYPE jsonb
+AS $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+}
+my %h;
+tie %h, 'PLPerlTiedHash';
+$h{a} = 1; $h{b} = 'boo'; $h{c} = undef;
+return \%h;
+$$;
+SELECT tied_jsonb_hash();
+ tied_jsonb_hash
+---------------------------------
+ {"a": 1, "b": "boo", "c": null}
+(1 row)
+
+CREATE FUNCTION tied_jsonb_array() RETURNS jsonb
+LANGUAGE plperl TRANSFORM FOR TYPE jsonb AS $$
+{
+ package PLPerlTiedArray;
+ sub TIEARRAY { bless [], $_[0] }
+ sub STORE { $_[0][$_[1]] = $_[2] }
+ sub FETCH { $_[0][$_[1]] }
+ sub FETCHSIZE { scalar @{$_[0]} }
+}
+my @a;
+tie @a, 'PLPerlTiedArray';
+$a[0] = 1; $a[1] = 'boo';
+return \@a;
+$$;
+SELECT tied_jsonb_array();
+ tied_jsonb_array
+------------------
+ [1, "boo"]
+(1 row)
+
-- this revealed a bug in the original implementation
CREATE FUNCTION testRegexpResultToJsonb() RETURNS jsonb
LANGUAGE plperl
@@ -250,4 +294,4 @@ SELECT roundtrip('{"1": {"2": [3, 4, 5]}, "2": 3}', 'HASH');
\set VERBOSITY terse \\ -- suppress cascade details
DROP EXTENSION plperl CASCADE;
-NOTICE: drop cascades to 8 other objects
+NOTICE: drop cascades to 10 other objects
diff --git a/contrib/jsonb_plperl/jsonb_plperl.c b/contrib/jsonb_plperl/jsonb_plperl.c
index ce6b62b9380..4010e49d33e 100644
--- a/contrib/jsonb_plperl/jsonb_plperl.c
+++ b/contrib/jsonb_plperl/jsonb_plperl.c
@@ -166,7 +166,7 @@ HV_to_JsonbValue(HV *obj, JsonbInState *jsonb_state)
while ((he = hv_iternext(obj)))
{
char *k = hek2cstr(he);
- SV *val = HeVAL(he);
+ SV *val = hv_iterval(obj, he);
key.val.string.val = k;
key.val.string.len = strlen(k);
@@ -187,6 +187,7 @@ SV_to_JsonbValue(SV *in, JsonbInState *jsonb_state, bool is_elem)
check_stack_depth();
/* Dereference references recursively. */
+ plperl_materialize_sv(in);
while (in && SvROK(in))
{
/*
@@ -196,6 +197,7 @@ SV_to_JsonbValue(SV *in, JsonbInState *jsonb_state, bool is_elem)
*/
CHECK_FOR_INTERRUPTS();
in = SvRV(in);
+ plperl_materialize_sv(in);
}
if (!in)
diff --git a/contrib/jsonb_plperl/sql/jsonb_plperl.sql b/contrib/jsonb_plperl/sql/jsonb_plperl.sql
index a5b2cffe6b7..c83698814d4 100644
--- a/contrib/jsonb_plperl/sql/jsonb_plperl.sql
+++ b/contrib/jsonb_plperl/sql/jsonb_plperl.sql
@@ -46,6 +46,45 @@ $$;
SELECT testUVToJsonb() IN ('18446744073709551615'::jsonb, '4294967295'::jsonb);
+-- test tied hash and array cases
+CREATE FUNCTION tied_jsonb_hash() RETURNS jsonb
+LANGUAGE plperl
+TRANSFORM FOR TYPE jsonb
+AS $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+}
+my %h;
+tie %h, 'PLPerlTiedHash';
+$h{a} = 1; $h{b} = 'boo'; $h{c} = undef;
+return \%h;
+$$;
+
+SELECT tied_jsonb_hash();
+
+CREATE FUNCTION tied_jsonb_array() RETURNS jsonb
+LANGUAGE plperl TRANSFORM FOR TYPE jsonb AS $$
+{
+ package PLPerlTiedArray;
+ sub TIEARRAY { bless [], $_[0] }
+ sub STORE { $_[0][$_[1]] = $_[2] }
+ sub FETCH { $_[0][$_[1]] }
+ sub FETCHSIZE { scalar @{$_[0]} }
+}
+my @a;
+tie @a, 'PLPerlTiedArray';
+$a[0] = 1; $a[1] = 'boo';
+return \@a;
+$$;
+
+SELECT tied_jsonb_array();
+
+
-- this revealed a bug in the original implementation
CREATE FUNCTION testRegexpResultToJsonb() RETURNS jsonb
LANGUAGE plperl
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index d7c8917f822..85729434853 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -63,7 +63,7 @@ endif
REGRESS_OPTS = --dbname=$(PL_TESTDB) --dlpath=$(top_builddir)/src/test/regress
REGRESS = plperl_setup plperl plperl_lc plperl_trigger plperl_shared \
plperl_elog plperl_unicode plperl_util plperl_init plperlu plperl_array \
- plperl_call plperl_transaction plperl_env
+ plperl_call plperl_transaction plperl_env plperl_tied
# if Perl can support two interpreters in one backend,
# test plperl-and-plperlu cases
ifneq ($(PERL),)
diff --git a/src/pl/plperl/expected/plperl_tied.out b/src/pl/plperl/expected/plperl_tied.out
new file mode 100644
index 00000000000..6d85dd855f2
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_tied.out
@@ -0,0 +1,132 @@
+-- Test tied Perl values via handmade classes, so as not to require
+-- Tie::Hash and Tie::Array; some popular platforms don't have those
+-- in their base Perl installations.
+DO $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+
+ package PLPerlTiedArray;
+ sub TIEARRAY { bless [], $_[0] }
+ sub STORE { $_[0][$_[1]] = $_[2] }
+ sub FETCH { $_[0][$_[1]] }
+ sub FETCHSIZE { scalar @{$_[0]} }
+
+ package PLPerlTiedScalar;
+ sub TIESCALAR { my $s; bless \$s, $_[0] }
+ sub STORE { ${$_[0]} = $_[1] }
+ sub FETCH { ${$_[0]} }
+}
+$$ LANGUAGE plperl;
+CREATE FUNCTION tied_setof() RETURNS SETOF text AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 'a'; $a[1] = 'b'; $a[2] = 'c';
+ return \@a;
+$$ LANGUAGE plperl;
+SELECT * FROM tied_setof();
+ tied_setof
+------------
+ a
+ b
+ c
+(3 rows)
+
+CREATE FUNCTION tied_scalar() RETURNS text AS $$
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = 'hello';
+ return $s;
+$$ LANGUAGE plperl;
+SELECT tied_scalar();
+ tied_scalar
+-------------
+ hello
+(1 row)
+
+CREATE TYPE tiedrowperl AS (f1 integer, f2 text, f3 text);
+CREATE FUNCTION tied_composite() RETURNS tiedrowperl AS $$
+ my %h;
+ tie %h, 'PLPerlTiedHash';
+ $h{f1} = 1; $h{f2} = 'hello'; $h{f3} = 'world';
+ return \%h;
+$$ LANGUAGE plperl;
+SELECT tied_composite();
+ tied_composite
+-----------------
+ (1,hello,world)
+(1 row)
+
+CREATE FUNCTION tied_int_array() RETURNS integer[] AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 1; $a[1] = 2; $a[2] = 3;
+ return \@a;
+$$ LANGUAGE plperl;
+SELECT tied_int_array();
+ tied_int_array
+----------------
+ {1,2,3}
+(1 row)
+
+-- Tied scalar whose FETCH returns an arrayref.
+CREATE FUNCTION tied_scalar_setof() RETURNS SETOF text AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 'x'; $a[1] = 'y';
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = \@a;
+ return $s;
+$$ LANGUAGE plperl;
+SELECT * FROM tied_scalar_setof();
+ tied_scalar_setof
+-------------------
+ x
+ y
+(2 rows)
+
+CREATE FUNCTION tied_scalar_int_array() RETURNS integer[] AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 4; $a[1] = 5;
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = \@a;
+ return $s;
+$$ LANGUAGE plperl;
+SELECT tied_scalar_int_array();
+ tied_scalar_int_array
+-----------------------
+ {4,5}
+(1 row)
+
+-- Artificial: $_TD->{new} and the trigger return value are tied scalars.
+CREATE TABLE tied_trigger_test (i int, v text);
+CREATE FUNCTION tied_modify() RETURNS trigger AS $$
+ my %h;
+ tie %h, 'PLPerlTiedHash';
+ $h{i} = $_TD->{new}{i};
+ $h{v} = 'from_tie';
+ my $new;
+ tie $new, 'PLPerlTiedScalar';
+ $new = \%h;
+ $_TD->{new} = $new;
+ my $ret;
+ tie $ret, 'PLPerlTiedScalar';
+ $ret = 'MODIFY';
+ return $ret;
+$$ LANGUAGE plperl;
+CREATE TRIGGER tied_modify_trig BEFORE INSERT ON tied_trigger_test
+FOR EACH ROW EXECUTE PROCEDURE tied_modify();
+INSERT INTO tied_trigger_test (i, v) VALUES (1, 'orig');
+SELECT i, v FROM tied_trigger_test;
+ i | v
+---+----------
+ 1 | from_tie
+(1 row)
+
diff --git a/src/pl/plperl/meson.build b/src/pl/plperl/meson.build
index ff41812ca46..5c055f4f662 100644
--- a/src/pl/plperl/meson.build
+++ b/src/pl/plperl/meson.build
@@ -96,6 +96,7 @@ tests += {
'plperl_call',
'plperl_transaction',
'plperl_env',
+ 'plperl_tied',
],
'regress_args': ['--dlpath', meson.project_build_root() / 'src/test/regress'],
},
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 5d14d0ab738..ace39cd072b 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1039,7 +1039,7 @@ plperl_build_tuple_result(HV *perlhash, TupleDesc td)
while ((he = hv_iternext(perlhash)))
{
char *key = hek2cstr(he);
- SV *val = HeVAL(he);
+ SV *val = hv_iterval(perlhash, he);
int attn = SPI_fnumber(td, key);
Form_pg_attribute attr;
@@ -1082,8 +1082,13 @@ plperl_hash_to_datum(SV *src, TupleDesc td)
}
/*
- * if we are an array ref return the reference. this is special in that if we
- * are a PostgreSQL::InServer::ARRAY object we will return the 'magic' array.
+ * If sv is an array ref return the reference, else return NULL.
+ *
+ * This is special in that if sv is a PostgreSQL::InServer::ARRAY object
+ * we will fetch its 'magic' array.
+ *
+ * The caller must already have invoked plperl_materialize_sv() on sv.
+ * sv may be NULL.
*/
static SV *
get_perl_array_ref(SV *sv)
@@ -1099,9 +1104,13 @@ get_perl_array_ref(SV *sv)
HV *hv = (HV *) SvRV(sv);
SV **sav = hv_fetch_string(hv, "array");
- if (sav && *sav && SvOK(*sav) && SvROK(*sav) &&
- SvTYPE(SvRV(*sav)) == SVt_PVAV)
- return *sav;
+ if (sav && *sav)
+ {
+ plperl_materialize_sv(*sav);
+ if (SvOK(*sav) && SvROK(*sav) &&
+ SvTYPE(SvRV(*sav)) == SVt_PVAV)
+ return *sav;
+ }
elog(ERROR, "could not get array reference from PostgreSQL::InServer::ARRAY object");
}
@@ -1135,11 +1144,14 @@ array_to_datum_internal(AV *av, ArrayBuildState **astatep,
{
/* fetch the array element */
SV **svp = av_fetch(av, i, FALSE);
+ SV *elem = svp ? *svp : NULL;
+ SV *sav;
- /* see if this element is an array, if so get that */
- SV *sav = svp ? get_perl_array_ref(*svp) : NULL;
+ /* cope with get magic on the array element */
+ plperl_materialize_sv(elem);
/* multi-dimensional array? */
+ sav = get_perl_array_ref(elem);
if (sav)
{
AV *nav = (AV *) SvRV(sav);
@@ -1185,7 +1197,7 @@ array_to_datum_internal(AV *av, ArrayBuildState **astatep,
(errcode(ERRCODE_INVALID_TEXT_REPRESENTATION),
errmsg("multidimensional arrays must have array expressions with matching dimensions")));
- dat = plperl_sv_to_datum(svp ? *svp : NULL,
+ dat = plperl_sv_to_datum(elem,
elemtypid,
typmod,
NULL,
@@ -1299,6 +1311,7 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
FmgrInfo *finfo, Oid typioparam,
bool *isnull)
{
+ dTHX;
FmgrInfo tmp;
Oid funcid;
@@ -1307,6 +1320,8 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
*isnull = false;
+ plperl_materialize_sv(sv);
+
/*
* Return NULL if result is undef, or if we're in a function returning
* VOID. In the latter case, we should pay no attention to the last Perl
@@ -1751,6 +1766,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("$_TD->{new} does not exist")));
+ plperl_materialize_sv(*svp);
if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
@@ -1768,7 +1784,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
while ((he = hv_iternext(hvNew)))
{
char *key = hek2cstr(he);
- SV *val = HeVAL(he);
+ SV *val = hv_iterval(hvNew, he);
int attn = SPI_fnumber(tupdesc, key);
Form_pg_attribute attr;
@@ -2429,6 +2445,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
if (prodesc->fn_retisset)
{
+ dTHX;
SV *sav;
/*
@@ -2437,10 +2454,10 @@ plperl_func_handler(PG_FUNCTION_ARGS)
* SRFs that didn't know about return_next(). Any other sort of return
* value is an error, except undef which means return an empty set.
*/
+ plperl_materialize_sv(perlret);
sav = get_perl_array_ref(perlret);
if (sav)
{
- dTHX;
AV *rav = (AV *) SvRV(sav);
Size_t alen = av_count(rav);
@@ -2494,6 +2511,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
static Datum
plperl_trigger_handler(PG_FUNCTION_ARGS)
{
+ dTHX;
plperl_proc_desc *prodesc;
SV *perlret;
Datum retval;
@@ -2537,6 +2555,8 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
+ plperl_materialize_sv(perlret);
+
if (perlret == NULL || !SvOK(perlret))
{
/* undef result means go ahead with original tuple */
@@ -3333,8 +3353,10 @@ plperl_return_next_internal(SV *sv)
if (prodesc->fn_retistuple)
{
+ dTHX;
HeapTuple tuple;
+ plperl_materialize_sv(sv);
if (!(SvOK(sv) && SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV))
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h
index 33180b16b6e..9e899b8b2e2 100644
--- a/src/pl/plperl/plperl.h
+++ b/src/pl/plperl/plperl.h
@@ -163,6 +163,16 @@ cstr2sv(const char *str)
return sv;
}
+/*
+ * If the SV has get magic, run FETCH to convert it to the intended value.
+ *
+ * While Perl functions such as SvPV() will handle get magic automatically,
+ * we must run this before primitive checks such as SvOK() or SvROK().
+ * This must be invoked within the scope of a dTHX declaration.
+ */
+#define plperl_materialize_sv(sv) \
+ do { if (sv) SvGETMAGIC(sv); } while(0)
+
/*
* Convert a HE (hash entry) key to a cstr in the current database encoding.
* The result is palloc'd.
diff --git a/src/pl/plperl/sql/plperl_tied.sql b/src/pl/plperl/sql/plperl_tied.sql
new file mode 100644
index 00000000000..5f546cc72c3
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_tied.sql
@@ -0,0 +1,113 @@
+-- Test tied Perl values via handmade classes, so as not to require
+-- Tie::Hash and Tie::Array; some popular platforms don't have those
+-- in their base Perl installations.
+
+DO $$
+{
+ package PLPerlTiedHash;
+ sub TIEHASH { bless {}, $_[0] }
+ sub STORE { $_[0]{$_[1]} = $_[2] }
+ sub FETCH { $_[0]{$_[1]} }
+ sub FIRSTKEY { my $a = keys %{$_[0]}; each %{$_[0]} }
+ sub NEXTKEY { each %{$_[0]} }
+
+ package PLPerlTiedArray;
+ sub TIEARRAY { bless [], $_[0] }
+ sub STORE { $_[0][$_[1]] = $_[2] }
+ sub FETCH { $_[0][$_[1]] }
+ sub FETCHSIZE { scalar @{$_[0]} }
+
+ package PLPerlTiedScalar;
+ sub TIESCALAR { my $s; bless \$s, $_[0] }
+ sub STORE { ${$_[0]} = $_[1] }
+ sub FETCH { ${$_[0]} }
+}
+$$ LANGUAGE plperl;
+
+CREATE FUNCTION tied_setof() RETURNS SETOF text AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 'a'; $a[1] = 'b'; $a[2] = 'c';
+ return \@a;
+$$ LANGUAGE plperl;
+
+SELECT * FROM tied_setof();
+
+CREATE FUNCTION tied_scalar() RETURNS text AS $$
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = 'hello';
+ return $s;
+$$ LANGUAGE plperl;
+
+SELECT tied_scalar();
+
+CREATE TYPE tiedrowperl AS (f1 integer, f2 text, f3 text);
+
+CREATE FUNCTION tied_composite() RETURNS tiedrowperl AS $$
+ my %h;
+ tie %h, 'PLPerlTiedHash';
+ $h{f1} = 1; $h{f2} = 'hello'; $h{f3} = 'world';
+ return \%h;
+$$ LANGUAGE plperl;
+
+SELECT tied_composite();
+
+CREATE FUNCTION tied_int_array() RETURNS integer[] AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 1; $a[1] = 2; $a[2] = 3;
+ return \@a;
+$$ LANGUAGE plperl;
+
+SELECT tied_int_array();
+
+-- Tied scalar whose FETCH returns an arrayref.
+CREATE FUNCTION tied_scalar_setof() RETURNS SETOF text AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 'x'; $a[1] = 'y';
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = \@a;
+ return $s;
+$$ LANGUAGE plperl;
+
+SELECT * FROM tied_scalar_setof();
+
+CREATE FUNCTION tied_scalar_int_array() RETURNS integer[] AS $$
+ my @a;
+ tie @a, 'PLPerlTiedArray';
+ $a[0] = 4; $a[1] = 5;
+ my $s;
+ tie $s, 'PLPerlTiedScalar';
+ $s = \@a;
+ return $s;
+$$ LANGUAGE plperl;
+
+SELECT tied_scalar_int_array();
+
+-- Artificial: $_TD->{new} and the trigger return value are tied scalars.
+CREATE TABLE tied_trigger_test (i int, v text);
+
+CREATE FUNCTION tied_modify() RETURNS trigger AS $$
+ my %h;
+ tie %h, 'PLPerlTiedHash';
+ $h{i} = $_TD->{new}{i};
+ $h{v} = 'from_tie';
+ my $new;
+ tie $new, 'PLPerlTiedScalar';
+ $new = \%h;
+ $_TD->{new} = $new;
+ my $ret;
+ tie $ret, 'PLPerlTiedScalar';
+ $ret = 'MODIFY';
+ return $ret;
+$$ LANGUAGE plperl;
+
+CREATE TRIGGER tied_modify_trig BEFORE INSERT ON tied_trigger_test
+FOR EACH ROW EXECUTE PROCEDURE tied_modify();
+
+INSERT INTO tied_trigger_test (i, v) VALUES (1, 'orig');
+
+SELECT i, v FROM tied_trigger_test;