From: Andrey Rachitskiy 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. 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..1bb67cff356 --- /dev/null +++ b/src/pl/plperl/expected/plperl_tied.out @@ -0,0 +1,98 @@ +-- 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) + +-- Artificial: replace $_TD->{new} with a tied hash. +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'; + $_TD->{new} = \%h; + return 'MODIFY'; +$$ 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(); +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..bf0498c8592 --- /dev/null +++ b/src/pl/plperl/sql/plperl_tied.sql @@ -0,0 +1,78 @@ +-- 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(); + +-- Artificial: replace $_TD->{new} with a tied hash. +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'; + $_TD->{new} = \%h; + return 'MODIFY'; +$$ 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(); +DROP TABLE tied_trigger_test; +DROP TYPE tiedrowperl;