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;