пн, 17 авг. 2026 г. в 03:24, Andrey Rachitskiy <[email protected]>:
> The first patch tries to close every Perl-to-SQL path that still
> ignored FETCH on tied values.
>
> I have attached v2.
The previous version missed a few GETMAGIC call sites:
get_perl_array_ref(), the trigger return value, $_TD->{new} before
the SvOK() / SvROK() checks, and the start of return_next(). A tied
scalar whose FETCH returns an arrayref or a hashref still looked like
undef.
That also made the SETOF walker cleaner. The loop only walks with
av_len() and calls return_next(). FETCH lives in return_next() and
plperl_sv_to_datum(), so the loop does not run GETMAGIC on each
element itself.
The regress patch covers those cases. tied_scalar_setof and
tied_scalar_int_array wrap an arrayref in a tied scalar. tied_modify
uses tied scalars for $_TD->{new} and for the "MODIFY" return.
--
Regards,
Rachitskiy Andrey
From: Andrey Rachitskiy <[email protected]>
Subject: [PATCH 2/2] Add regress tests for tied Perl hashes and arrays
Inline tie classes without Tie::Hash / Tie::Array. Trusted plperl
cannot require those modules. Shared class setup is only in
plperl_tied, where several functions reuse it. Include tied scalars
that wrap arrayrefs and trigger return / $_TD->{new} values.
diff --git a/contrib/hstore_plperl/Makefile b/contrib/hstore_plperl/Makefile
index 9065f164088..efb0640902c 100644
--- a/contrib/hstore_plperl/Makefile
+++ b/contrib/hstore_plperl/Makefile
@@ -10,7 +10,7 @@ PGFILEDESC = "hstore_plperl - hstore transform for plperl"
EXTENSION = hstore_plperl hstore_plperlu
DATA = hstore_plperl--1.0.sql hstore_plperlu--1.0.sql
-REGRESS = hstore_plperl hstore_plperlu create_transform
+REGRESS = hstore_plperl hstore_plperlu hstore_plperl_tied create_transform
EXTRA_INSTALL = contrib/hstore
ifdef USE_PGXS
diff --git a/contrib/hstore_plperl/expected/hstore_plperl_tied.out b/contrib/hstore_plperl/expected/hstore_plperl_tied.out
new file mode 100644
index 00000000000..2cd85facd5a
--- /dev/null
+++ b/contrib/hstore_plperl/expected/hstore_plperl_tied.out
@@ -0,0 +1,26 @@
+CREATE EXTENSION hstore_plperl CASCADE;
+NOTICE: installing required extension "hstore"
+NOTICE: installing required extension "plperl"
+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 tied_hstore();
+DROP EXTENSION hstore_plperl, hstore, plperl;
diff --git a/contrib/hstore_plperl/meson.build b/contrib/hstore_plperl/meson.build
index 705dbe69a46..0f12bdc7101 100644
--- a/contrib/hstore_plperl/meson.build
+++ b/contrib/hstore_plperl/meson.build
@@ -45,6 +45,7 @@ tests += {
'sql': [
'hstore_plperl',
'hstore_plperlu',
+ 'hstore_plperl_tied',
'create_transform',
],
},
diff --git a/contrib/hstore_plperl/sql/hstore_plperl_tied.sql b/contrib/hstore_plperl/sql/hstore_plperl_tied.sql
new file mode 100644
index 00000000000..229b7bbaecf
--- /dev/null
+++ b/contrib/hstore_plperl/sql/hstore_plperl_tied.sql
@@ -0,0 +1,21 @@
+CREATE EXTENSION hstore_plperl CASCADE;
+
+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 tied_hstore();
+DROP EXTENSION hstore_plperl, hstore, plperl;
diff --git a/contrib/jsonb_plperl/Makefile b/contrib/jsonb_plperl/Makefile
index ba9480e819b..8f8ea1ff2e7 100644
--- a/contrib/jsonb_plperl/Makefile
+++ b/contrib/jsonb_plperl/Makefile
@@ -11,7 +11,7 @@ PG_CPPFLAGS = -I$(top_srcdir)/src/pl/plperl
EXTENSION = jsonb_plperlu jsonb_plperl
DATA = jsonb_plperlu--1.0.sql jsonb_plperl--1.0.sql
-REGRESS = jsonb_plperl jsonb_plperlu
+REGRESS = jsonb_plperl jsonb_plperlu jsonb_plperl_tied
SHLIB_LINK += $(filter -lm, $(LIBS))
diff --git a/contrib/jsonb_plperl/expected/jsonb_plperl_tied.out b/contrib/jsonb_plperl/expected/jsonb_plperl_tied.out
new file mode 100644
index 00000000000..74acace939c
--- /dev/null
+++ b/contrib/jsonb_plperl/expected/jsonb_plperl_tied.out
@@ -0,0 +1,45 @@
+CREATE EXTENSION jsonb_plperl CASCADE;
+NOTICE: installing required extension "plperl"
+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)
+
+DROP FUNCTION tied_jsonb_hash(), tied_jsonb_array();
+DROP EXTENSION jsonb_plperl, plperl;
diff --git a/contrib/jsonb_plperl/meson.build b/contrib/jsonb_plperl/meson.build
index 8bfabee5455..27654ce8d55 100644
--- a/contrib/jsonb_plperl/meson.build
+++ b/contrib/jsonb_plperl/meson.build
@@ -46,6 +46,7 @@ tests += {
'sql': [
'jsonb_plperl',
'jsonb_plperlu',
+ 'jsonb_plperl_tied',
],
},
}
diff --git a/contrib/jsonb_plperl/sql/jsonb_plperl_tied.sql b/contrib/jsonb_plperl/sql/jsonb_plperl_tied.sql
new file mode 100644
index 00000000000..e687547d682
--- /dev/null
+++ b/contrib/jsonb_plperl/sql/jsonb_plperl_tied.sql
@@ -0,0 +1,37 @@
+CREATE EXTENSION jsonb_plperl CASCADE;
+
+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();
+
+DROP FUNCTION tied_jsonb_hash(), tied_jsonb_array();
+DROP EXTENSION jsonb_plperl, 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..3d09085b955
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_tied.out
@@ -0,0 +1,137 @@
+-- Tied Perl values via inline classes (no Tie::Hash / Tie::Array).
+-- Trusted plperl cannot require those modules.
+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)
+
+DROP TRIGGER tied_modify_trig ON tied_trigger_test;
+DROP FUNCTION tied_modify(), tied_setof(), tied_scalar(),
+ tied_composite(), tied_int_array(),
+ tied_scalar_setof(), tied_scalar_int_array();
+DROP TABLE tied_trigger_test;
+DROP TYPE tiedrowperl;
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/sql/plperl_tied.sql b/src/pl/plperl/sql/plperl_tied.sql
new file mode 100644
index 00000000000..7701a53839b
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_tied.sql
@@ -0,0 +1,108 @@
+-- Tied Perl values via inline classes (no Tie::Hash / Tie::Array).
+-- Trusted plperl cannot require those modules.
+
+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;
+
+DROP TRIGGER tied_modify_trig ON tied_trigger_test;
+DROP FUNCTION tied_modify(), tied_setof(), tied_scalar(),
+ tied_composite(), tied_int_array(),
+ tied_scalar_setof(), tied_scalar_int_array();
+DROP TABLE tied_trigger_test;
+DROP TYPE tiedrowperl;
From: Andrey Rachitskiy <[email protected]>
Subject: [PATCH 1/2] Honor Perl FETCH for tied hashes and arrays
Tied hashes leave HeVAL() unset after hv_iternext(). Call hv_iterval()
and SvGETMAGIC() so FETCH actually runs. For SETOF arrays, walk with
av_len() and run GETMAGIC via return_next / plperl_sv_to_datum.
Apply the same pattern in get_perl_array_ref(), plperl_sv_to_datum(),
jsonb_plperl, composite and trigger hash walkers, and the remaining
SvOK() checks on trigger / return_next entry points.
diff --git a/contrib/hstore_plperl/hstore_plperl.c b/contrib/hstore_plperl/hstore_plperl.c
index d7f1b8ddb48..ad205c8bcfc 100644
--- a/contrib/hstore_plperl/hstore_plperl.c
+++ b/contrib/hstore_plperl/hstore_plperl.c
@@ -138,7 +138,14 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
while ((he = hv_iternext(hv)))
{
char *key = sv2cstr(HeSVKEY_force(he));
- SV *value = HeVAL(he);
+ SV *value;
+
+ /*
+ * Tied hashes leave HeVAL() unset. hv_iterval() plus
+ * SvGETMAGIC() runs FETCH.
+ */
+ value = hv_iterval(hv, he);
+ SvGETMAGIC(value);
if (i >= pcount)
{
diff --git a/contrib/jsonb_plperl/jsonb_plperl.c b/contrib/jsonb_plperl/jsonb_plperl.c
index 97d147cc65a..097c43cfb08 100644
--- a/contrib/jsonb_plperl/jsonb_plperl.c
+++ b/contrib/jsonb_plperl/jsonb_plperl.c
@@ -186,6 +186,9 @@ SV_to_JsonbValue(SV *in, JsonbInState *jsonb_state, bool is_elem)
/* this can recurse via AV_to_JsonbValue() or HV_to_JsonbValue() */
check_stack_depth();
+ /* Tied values leave SvOK() false until FETCH. */
+ SvGETMAGIC(in);
+
/* Dereference references recursively. */
while (SvROK(in))
{
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index eba91f2d7d6..874e7e310b6 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1092,11 +1092,19 @@ plperl_build_tuple_result(HV *perlhash, TupleDesc td)
hv_iterinit(perlhash);
while ((he = hv_iternext(perlhash)))
{
- SV *val = HeVAL(he);
- char *key = hek2cstr(he);
- int attn = SPI_fnumber(td, key);
+ char *key;
+ SV *val;
+ int attn;
Form_pg_attribute attr;
+ /*
+ * Tied hashes leave HeVAL() unset. hek2cstr() uses FREETMPS, so
+ * it must run before hv_iterval().
+ */
+ key = hek2cstr(he);
+ val = hv_iterval(perlhash, he);
+ attn = SPI_fnumber(td, key);
+
if (attn == SPI_ERROR_NOATTRIBUTE)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
@@ -1145,6 +1153,12 @@ get_perl_array_ref(SV *sv)
{
dTHX;
+ if (!sv)
+ return NULL;
+
+ /* Tied scalars leave SvOK()/SvROK() false until FETCH. */
+ SvGETMAGIC(sv);
+
if (SvOK(sv) && SvROK(sv))
{
if (SvTYPE(SvRV(sv)) == SVt_PVAV)
@@ -1154,9 +1168,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)
+ {
+ SvGETMAGIC(*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");
}
@@ -1348,6 +1366,12 @@ plperl_sv_to_datum(SV *sv, Oid typid, int32 typmod,
* VOID. In the latter case, we should pay no attention to the last Perl
* statement's result, and this is a convenient means to ensure that.
*/
+ if (sv)
+ {
+ dTHX;
+ SvGETMAGIC(sv);
+ }
+
if (!sv || !SvOK(sv) || typid == VOIDOID)
{
/* look up type info if they did not pass it */
@@ -1787,6 +1811,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
errmsg("$_TD->{new} does not exist")));
+ SvGETMAGIC(*svp);
if (!SvOK(*svp) || !SvROK(*svp) || SvTYPE(SvRV(*svp)) != SVt_PVHV)
ereport(ERROR,
(errcode(ERRCODE_DATATYPE_MISMATCH),
@@ -1803,11 +1828,16 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
hv_iterinit(hvNew);
while ((he = hv_iternext(hvNew)))
{
- char *key = hek2cstr(he);
- SV *val = HeVAL(he);
- int attn = SPI_fnumber(tupdesc, key);
+ char *key;
+ SV *val;
+ int attn;
Form_pg_attribute attr;
+ /* hek2cstr() uses FREETMPS, so it must run before hv_iterval(). */
+ key = hek2cstr(he);
+ val = hv_iterval(hvNew, he);
+ attn = SPI_fnumber(tupdesc, key);
+
if (attn == SPI_ERROR_NOATTRIBUTE)
ereport(ERROR,
(errcode(ERRCODE_UNDEFINED_COLUMN),
@@ -2478,14 +2508,15 @@ plperl_func_handler(PG_FUNCTION_ARGS)
if (sav)
{
dTHX;
- int i = 0;
- SV **svp = 0;
AV *rav = (AV *) SvRV(sav);
+ int alen = av_len(rav) + 1;
- while ((svp = av_fetch(rav, i, FALSE)) != NULL)
+ for (int i = 0; i < alen; i++)
{
- plperl_return_next_internal(*svp);
- i++;
+ SV **svp = av_fetch(rav, i, FALSE);
+
+ if (svp)
+ plperl_return_next_internal(*svp);
}
}
else if (SvOK(perlret))
@@ -2573,6 +2604,13 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
if (SPI_finish() != SPI_OK_FINISH)
elog(ERROR, "SPI_finish() failed");
+ if (perlret)
+ {
+ dTHX;
+
+ SvGETMAGIC(perlret);
+ }
+
if (perlret == NULL || !SvOK(perlret))
{
/* undef result means go ahead with original tuple */
@@ -3293,6 +3331,13 @@ plperl_return_next_internal(SV *sv)
if (!sv)
return;
+ {
+ dTHX;
+
+ /* Tied scalars leave SvOK()/SvROK() false until FETCH. */
+ SvGETMAGIC(sv);
+ }
+
prodesc = current_call_data->prodesc;
fcinfo = current_call_data->fcinfo;
rsi = (ReturnSetInfo *) fcinfo->resultinfo;
