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
2026-10-23 13:29:09 +03:00 · 2026-08-19 14:06:52 -04:00
parent 8637383f5f
commit ccab6d36d0
12 changed files with 431 additions and 17 deletions
--- 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;
--- 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)
 		{
--- 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;
--- 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
--- 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)
--- 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
--- 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),)
--- a/src/pl/plperl/expected/plperl_tied.out
+++ 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)
+
--- 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'],
  },
--- 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),
--- 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.
--- a/src/pl/plperl/sql/plperl_tied.sql
+++ 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;