вс, 16 авг. 2026 г. в 22:38, Tom Lane <[email protected]>:One interesting
point is that Claude Opus, which constructed
> these test cases, seemed to think that we ought to be able
> to read out the values assigned to the tied array or hash.
> But what the repaired code actually produces is SQL NULLs.
> AFAICT we are getting Perl "undef" values out of hv_iternext
> or av_fetch, so it's hard to see how we could do any better.
>
> Hi Tom!
A tied hash does not store the value in HeVAL(). hv_iternext() leaves that
pointer unset. Tom's NULL check therefore always takes the SQL NULL path,
even when FETCH would return a real value. hv_iterval() plus SvGETMAGIC()
is what actually runs FETCH.
The same applies to a tied array. av_len() stops the infinite loop, but
av_fetch() still returns a magic SV whose SvOK() is false until GETMAGIC.
Without that, SETOF also yields NULLs.
The attached patch includes regress tests. They use a small inline TIEHASH
/ TIEARRAY class, not Tie::Hash or Tie::Array.
--
Regards,
Rachitskiy Andrey
diff --git a/contrib/hstore_plperl/expected/hstore_plperl.out b/contrib/hstore_plperl/expected/hstore_plperl.out
index 1ab09a94cda..958c1d3056d 100644
--- a/contrib/hstore_plperl/expected/hstore_plperl.out
+++ b/contrib/hstore_plperl/expected/hstore_plperl.out
@@ -62,6 +62,33 @@ ERROR: cannot transform non-hash Perl value to hstore
CONTEXT: PL/Perl function "test2"
DROP FUNCTION test2();
DROP FUNCTION test2arr();
+-- Tied hash via an inline class (no Tie::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 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 d7f1b8ddb48..ee63c7d4492 100644
--- a/contrib/hstore_plperl/hstore_plperl.c
+++ b/contrib/hstore_plperl/hstore_plperl.c
@@ -138,7 +138,15 @@ 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);
+ if (value)
+ SvGETMAGIC(value);
if (i >= pcount)
{
@@ -150,7 +158,7 @@ plperl_to_hstore(PG_FUNCTION_ARGS)
pairs[i].keylen = hstoreCheckKeyLen(strlen(pairs[i].key));
pairs[i].needfree = true;
- if (!SvOK(value))
+ if (!value || !SvOK(value))
{
pairs[i].val = NULL;
pairs[i].vallen = 0;
diff --git a/contrib/hstore_plperl/sql/hstore_plperl.sql b/contrib/hstore_plperl/sql/hstore_plperl.sql
index ad1db7eae17..9624453b2df 100644
--- a/contrib/hstore_plperl/sql/hstore_plperl.sql
+++ b/contrib/hstore_plperl/sql/hstore_plperl.sql
@@ -54,6 +54,31 @@ SELECT test2();
DROP FUNCTION test2();
DROP FUNCTION test2arr();
+-- Tied hash via an inline class (no Tie::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 tied_hstore();
+
DROP EXTENSION hstore_plperl;
DROP EXTENSION hstore;
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index e3d7c8896a2..4fedc2c62b0 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -792,3 +792,28 @@ SELECT self_modify(42);
126
(1 row)
+-- Tied array via an inline class (no Tie::Array). av_fetch on a tied
+-- array never returns NULL, so walking until it does would not stop.
+CREATE OR REPLACE FUNCTION tied_setof() RETURNS SETOF text 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] = 'a';
+ $a[1] = 'b';
+ $a[2] = 'c';
+ return \@a;
+$$ LANGUAGE plperl;
+SELECT * FROM tied_setof();
+ tied_setof
+------------
+ a
+ b
+ c
+(3 rows)
+
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index eba91f2d7d6..14cb7a21162 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -2478,14 +2478,18 @@ 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)
+ {
+ SvGETMAGIC(*svp);
+ plperl_return_next_internal(*svp);
+ }
}
}
else if (SvOK(perlret))
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index bb0b8ce4cb6..d5f37e5e16e 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -521,3 +521,24 @@ $$ LANGUAGE plperl;
SELECT self_modify(42);
SELECT self_modify(42);
+
+-- Tied array via an inline class (no Tie::Array). av_fetch on a tied
+-- array never returns NULL, so walking until it does would not stop.
+CREATE OR REPLACE FUNCTION tied_setof() RETURNS SETOF text 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] = 'a';
+ $a[1] = 'b';
+ $a[2] = 'c';
+ return \@a;
+$$ LANGUAGE plperl;
+
+SELECT * FROM tied_setof();
+
