Skip to content

Commit 87bb2ad

Browse files
alvherrealvherre
committed
Convert Postgres arrays to Perl arrays on PL/perl input arguments
More generally, arrays are turned in Perl array references, and row and composite types are turned into Perl hash references. This is done recursively, in a way that's natural to every Perl programmer. To avoid a backwards compatibility hit, the string representation of each structure is also available if the function requests it. Authors: Alexey Klyukin and Alex Hunsaker. Some code cleanups by me.
1 parent f7b51d1 commit 87bb2ad

File tree

14 files changed

+1296
-368
lines changed

14 files changed

+1296
-368
lines changed

‎doc/src/sgml/plperl.sgml‎

Lines changed: 69 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -198,6 +198,42 @@ select returns_array();
198198
</programlisting>
199199
</para>
200200

201+
<para>
202+
Perl passes <productname>PostgreSQL</productname> arrays as a blessed
203+
PostgreSQL::InServer::ARRAY object. This object may be treated as an array
204+
reference or a string, allowing for backwards compatibility with Perl
205+
code written for <productname>PostgreSQL</productname> versions below 9.1 to
206+
run. For example:
207+
208+
<programlisting>
209+
CREATE OR REPLACE FUNCTION concat_array_elements(text[]) RETURNS TEXT AS $$
210+
my $arg = shift;
211+
my $result = "";
212+
return undef if (!defined $arg);
213+
214+
# as an array reference
215+
for (@$arg) {
216+
$result .= $_;
217+
}
218+
219+
# also works as a string
220+
$result .= $arg;
221+
222+
return $result;
223+
$$ LANGUAGE plperl;
224+
225+
SELECT concat_array_elements(ARRAY['PL','/','Perl']);
226+
</programlisting>
227+
228+
<note>
229+
<para>
230+
Multi-dimensional arrays are represented as references to
231+
lower-dimensional arrays of references in a way common to every Perl
232+
programmer.
233+
</para>
234+
</note>
235+
</para>
236+
201237
<para>
202238
Composite-type arguments are passed to the function as references
203239
to hashes. The keys of the hash are the attribute names of the
@@ -740,6 +776,22 @@ SELECT release_hosts_query();
740776
</listitem>
741777
</varlistentry>
742778

779+
<varlistentry>
780+
<indexterm>
781+
<primary>encode_typed_literal</primary>
782+
<secondary>in PL/Perl</secondary>
783+
</indexterm>
784+
785+
<term><literal><function>encode_typed_literal(<replaceable>value</replaceable>, <replaceable>typename</replaceable>)</function></literal></term>
786+
<listitem>
787+
<para>
788+
Converts a Perl variable to the value of the datatype passed as a
789+
second argument and returns a string representation of this value.
790+
Correctly handles nested arrays and values of composite types.
791+
</para>
792+
</listitem>
793+
</varlistentry>
794+
743795
<varlistentry>
744796
<indexterm>
745797
<primary>encode_array_constructor</primary>
@@ -775,8 +827,24 @@ SELECT release_hosts_query();
775827
</listitem>
776828
</varlistentry>
777829

830+
<varlistentry>
831+
<indexterm>
832+
<primary>is_array_ref</primary>
833+
<secondary>in PL/Perl</secondary>
834+
</indexterm>
835+
836+
<term><literal><function>is_array_ref(<replaceable>argument</replaceable>)</function></literal></term>
837+
<listitem>
838+
<para>
839+
Returns a true value if the given argument may be treated as an
840+
array reference, that is, if ref of the argument is <literal>ARRAY</> or
841+
<literal>PostgreSQL::InServer::ARRAY</>. Returns false otherwise.
842+
</para>
843+
</listitem>
844+
</varlistentry>
845+
778846
</variablelist>
779-
</sect2>
847+
</sect2>
780848
</sect1>
781849

782850
<sect1 id="plperl-global">

‎src/pl/plperl/GNUmakefile‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@ PERLCHUNKS = plc_perlboot.pl plc_trusted.pl
4141
SHLIB_LINK = $(perl_embed_ldflags)
4242

4343
REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu
44-
REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu
44+
REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array
4545
# if Perl can support two interpreters in one backend,
4646
# test plperl-and-plperlu cases
4747
ifneq ($(PERL),)

‎src/pl/plperl/Util.xs‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -198,6 +198,20 @@ looks_like_number(sv)
198198
OUTPUT:
199199
RETVAL
200200

201+
SV *
202+
encode_typed_literal(sv, typname)
203+
SV *sv
204+
char *typname;
205+
PREINIT:
206+
char *outstr;
207+
CODE:
208+
outstr = plperl_sv_to_literal(sv, typname);
209+
if (outstr == NULL)
210+
RETVAL = &PL_sv_undef;
211+
else
212+
RETVAL = cstr2sv(outstr);
213+
OUTPUT:
214+
RETVAL
201215

202216
BOOT:
203217
items = 0; /* avoid 'unused variable' warning */

‎src/pl/plperl/expected/plperl.out‎

Lines changed: 80 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,8 @@ SELECT * FROM perl_set_int(5);
6969
5
7070
(6 rows)
7171

72-
CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text);
72+
CREATE TYPE testnestperl AS (f5 integer[]);
73+
CREATE TYPE testrowperl AS (f1 integer, f2 text, f3 text, f4 testnestperl);
7374
CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
7475
return undef;
7576
$$ LANGUAGE plperl;
@@ -80,24 +81,24 @@ SELECT perl_row();
8081
(1 row)
8182

8283
SELECT * FROM perl_row();
83-
f1 | f2 | f3
84-
----+----+----
85-
| |
84+
f1 | f2 | f3 | f4
85+
----+----+----+----
86+
| | |
8687
(1 row)
8788

8889
CREATE OR REPLACE FUNCTION perl_row() RETURNS testrowperl AS $$
89-
return {f2 => 'hello', f1 => 1, f3 => 'world'};
90+
return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [[1]] } };
9091
$$ LANGUAGE plperl;
9192
SELECT perl_row();
92-
perl_row
93-
-----------------
94-
(1,hello,world)
93+
perl_row
94+
---------------------------
95+
(1,hello,world,"({{1}})")
9596
(1 row)
9697

9798
SELECT * FROM perl_row();
98-
f1 | f2 | f3
99-
----+-------+-------
100-
1 | hello | world
99+
f1 | f2 | f3 | f4
100+
----+-------+-------+---------
101+
1 | hello | world | ({{1}})
101102
(1 row)
102103

103104
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
@@ -109,15 +110,18 @@ SELECT perl_set();
109110
(0 rows)
110111

111112
SELECT * FROM perl_set();
112-
f1 | f2 | f3
113-
----+----+----
113+
f1 | f2 | f3 | f4
114+
----+----+----+----
114115
(0 rows)
115116

116117
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
117118
return [
118119
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
119120
undef,
120-
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
121+
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
122+
{ f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
123+
{ f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
124+
{ f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
121125
];
122126
$$ LANGUAGE plperl;
123127
SELECT perl_set();
@@ -129,25 +133,37 @@ CONTEXT: PL/Perl function "perl_set"
129133
CREATE OR REPLACE FUNCTION perl_set() RETURNS SETOF testrowperl AS $$
130134
return [
131135
{ f1 => 1, f2 => 'Hello', f3 => 'World' },
132-
{ f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL' },
133-
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl' }
136+
{ f1 => 2, f2 => 'Hello', f3 => 'PostgreSQL', 'f4' => undef },
137+
{ f1 => 3, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => {} },
138+
{ f1 => 4, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => undef }},
139+
{ f1 => 5, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => '{1}' }},
140+
{ f1 => 6, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => { 'f5' => [1] }},
141+
{ f1 => 7, f2 => 'Hello', f3 => 'PL/Perl', 'f4' => '({1})' },
134142
];
135143
$$ LANGUAGE plperl;
136144
SELECT perl_set();
137-
perl_set
138-
----------------------
139-
(1,Hello,World)
140-
(2,Hello,PostgreSQL)
141-
(3,Hello,PL/Perl)
142-
(3 rows)
145+
perl_set
146+
---------------------------
147+
(1,Hello,World,)
148+
(2,Hello,PostgreSQL,)
149+
(3,Hello,PL/Perl,"()")
150+
(4,Hello,PL/Perl,"()")
151+
(5,Hello,PL/Perl,"({1})")
152+
(6,Hello,PL/Perl,"({1})")
153+
(7,Hello,PL/Perl,"({1})")
154+
(7 rows)
143155

144156
SELECT * FROM perl_set();
145-
f1 | f2 | f3
146-
----+-------+------------
147-
1 | Hello | World
148-
2 | Hello | PostgreSQL
149-
3 | Hello | PL/Perl
150-
(3 rows)
157+
f1 | f2 | f3 | f4
158+
----+-------+------------+-------
159+
1 | Hello | World |
160+
2 | Hello | PostgreSQL |
161+
3 | Hello | PL/Perl | ()
162+
4 | Hello | PL/Perl | ()
163+
5 | Hello | PL/Perl | ({1})
164+
6 | Hello | PL/Perl | ({1})
165+
7 | Hello | PL/Perl | ({1})
166+
(7 rows)
151167

152168
CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
153169
return undef;
@@ -162,14 +178,14 @@ SELECT * FROM perl_record();
162178
ERROR: a column definition list is required for functions returning "record"
163179
LINE 1: SELECT * FROM perl_record();
164180
^
165-
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
166-
f1 | f2 | f3
167-
----+----+----
168-
| |
181+
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
182+
f1 | f2 | f3 | f4
183+
----+----+----+----
184+
| | |
169185
(1 row)
170186

171187
CREATE OR REPLACE FUNCTION perl_record() RETURNS record AS $$
172-
return {f2 => 'hello', f1 => 1, f3 => 'world'};
188+
return {f2 => 'hello', f1 => 1, f3 => 'world', 'f4' => { 'f5' => [1] } };
173189
$$ LANGUAGE plperl;
174190
SELECT perl_record();
175191
ERROR: function returning record called in context that cannot accept type record
@@ -178,10 +194,10 @@ SELECT * FROM perl_record();
178194
ERROR: a column definition list is required for functions returning "record"
179195
LINE 1: SELECT * FROM perl_record();
180196
^
181-
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text);
182-
f1 | f2 | f3
183-
----+-------+-------
184-
1 | hello | world
197+
SELECT * FROM perl_record() AS (f1 integer, f2 text, f3 text, f4 testnestperl);
198+
f1 | f2 | f3 | f4
199+
----+-------+-------+-------
200+
1 | hello | world | ({1})
185201
(1 row)
186202

187203
CREATE OR REPLACE FUNCTION perl_record_set() RETURNS SETOF record AS $$
@@ -474,7 +490,7 @@ SELECT * FROM recurse(3);
474490
(5 rows)
475491

476492
---
477-
--- Test arrary return
493+
--- Test array return
478494
---
479495
CREATE OR REPLACE FUNCTION array_of_text() RETURNS TEXT[][]
480496
LANGUAGE plperl as $$
@@ -555,6 +571,32 @@ $$ LANGUAGE plperl;
555571
SELECT perl_spi_prepared_bad(4.35) as "double precision";
556572
ERROR: type "does_not_exist" does not exist at line 2.
557573
CONTEXT: PL/Perl function "perl_spi_prepared_bad"
574+
-- Test with a row type
575+
CREATE OR REPLACE FUNCTION perl_spi_prepared() RETURNS INTEGER AS $$
576+
my $x = spi_prepare('select $1::footype AS a', 'footype');
577+
my $q = spi_exec_prepared( $x, '(1, 2)');
578+
spi_freeplan($x);
579+
return $q->{rows}->[0]->{a}->{x};
580+
$$ LANGUAGE plperl;
581+
SELECT * from perl_spi_prepared();
582+
perl_spi_prepared
583+
-------------------
584+
1
585+
(1 row)
586+
587+
CREATE OR REPLACE FUNCTION perl_spi_prepared_row(footype) RETURNS footype AS $$
588+
my $footype = shift;
589+
my $x = spi_prepare('select $1 AS a', 'footype');
590+
my $q = spi_exec_prepared( $x, {}, $footype );
591+
spi_freeplan($x);
592+
return $q->{rows}->[0]->{a};
593+
$$ LANGUAGE plperl;
594+
SELECT * from perl_spi_prepared_row('(1, 2)');
595+
x | y
596+
---+---
597+
1 | 2
598+
(1 row)
599+
558600
-- simple test of a DO block
559601
DO $$
560602
$a = 'This is a test';

0 commit comments

Comments
 (0)