Skip to content

Commit 1a7c2f9

Browse files
adunstanadunstan
committed
Various small improvements and cleanups for PL/Perl.
- Allow (ineffective) use of 'require' in plperl If the required module is not already loaded then it dies. So "use strict;" now works in plperl. - Pre-load the feature module if perl >= 5.10. So "use feature :5.10;" now works in plperl. - Stored procedure subs are now given names. The names are not visible in ordinary use, but they make tools like Devel::NYTProf and Devel::Cover much more useful. - Simplified and generalized the subroutine creation code. Now one code path for generating sub source code, not four. Can generate multiple 'use' statements with specific imports (which handles plperl.use_strict currently and can easily be extended to handle a plperl.use_feature=':5.12' in future). - Disallows use of Safe version 2.20 which is broken for PL/Perl. http://rt.perl.org/rt3/Ticket/Display.html?id=72068 - Assorted minor optimizations by pre-growing data structures. Patch from Tim Bunce, reviewed by Alex Hunsaker.
1 parent d879697 commit 1a7c2f9

File tree

9 files changed

+270
-176
lines changed

9 files changed

+270
-176
lines changed

‎doc/src/sgml/plperl.sgml

Lines changed: 31 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.74 2010/01/20 03:37:10 rhaas Exp $ -->
1+
<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.75 2010/01/26 23:11:56 adunstan Exp $ -->
22

33
<chapter id="plperl">
44
<title>PL/Perl - Perl Procedural Language</title>
@@ -285,29 +285,39 @@ SELECT * FROM perl_set();
285285
</para>
286286

287287
<para>
288-
If you wish to use the <literal>strict</> pragma with your code,
289-
the easiest way to do so is to <command>SET</>
290-
<literal>plperl.use_strict</literal> to true. This parameter affects
291-
subsequent compilations of <application>PL/Perl</> functions, but not
292-
functions already compiled in the current session. To set the
293-
parameter before <application>PL/Perl</> has been loaded, it is
294-
necessary to have added <quote><literal>plperl</></> to the <xref
295-
linkend="guc-custom-variable-classes"> list in
296-
<filename>postgresql.conf</filename>.
288+
If you wish to use the <literal>strict</> pragma with your code you have a few options.
289+
For temporary global use you can <command>SET</> <literal>plperl.use_strict</literal>
290+
to true (see <xref linkend="plperl.use_strict">).
291+
This will affect subsequent compilations of <application>PL/Perl</>
292+
functions, but not functions already compiled in the current session.
293+
For permanent global use you can set <literal>plperl.use_strict</literal>
294+
to true in the <filename>postgresql.conf</filename> file.
297295
</para>
298296

299297
<para>
300-
Another way to use the <literal>strict</> pragma is to put:
298+
For permanent use in specific functions you can simply put:
301299
<programlisting>
302300
use strict;
303301
</programlisting>
304-
in the function body. But this only works in <application>PL/PerlU</>
305-
functions, since the <literal>use</> triggers a <literal>require</>
306-
which is not a trusted operation. In
307-
<application>PL/Perl</> functions you can instead do:
308-
<programlisting>
309-
BEGIN { strict->import(); }
310-
</programlisting>
302+
at the top of the function body.
303+
</para>
304+
305+
<para>
306+
The <literal>feature</> pragma is also available to <function>use</> if your Perl is version 5.10.0 or higher.
307+
</para>
308+
309+
</sect1>
310+
311+
<sect1 id="plperl-data">
312+
<title>Data Values in PL/Perl</title>
313+
314+
<para>
315+
The argument values supplied to a PL/Perl function's code are
316+
simply the input arguments converted to text form (just as if they
317+
had been displayed by a <command>SELECT</command> statement).
318+
Conversely, the <function>return</function> and <function>return_next</function>
319+
commands will accept any string that is acceptable input format
320+
for the function's declared return type.
311321
</para>
312322
</sect1>
313323

@@ -682,18 +692,6 @@ SELECT done();
682692
</sect2>
683693
</sect1>
684694

685-
<sect1 id="plperl-data">
686-
<title>Data Values in PL/Perl</title>
687-
688-
<para>
689-
The argument values supplied to a PL/Perl function's code are
690-
simply the input arguments converted to text form (just as if they
691-
had been displayed by a <command>SELECT</command> statement).
692-
Conversely, the <literal>return</> command will accept any string
693-
that is acceptable input format for the function's declared return
694-
type. So, within the PL/Perl function,
695-
all values are just text strings.
696-
</para>
697695
</sect1>
698696

699697
<sect1 id="plperl-global">
@@ -1042,8 +1040,7 @@ CREATE TRIGGER test_valid_id_trig
10421040
<itemizedlist>
10431041
<listitem>
10441042
<para>
1045-
PL/Perl functions cannot call each other directly (because they
1046-
are anonymous subroutines inside Perl).
1043+
PL/Perl functions cannot call each other directly.
10471044
</para>
10481045
</listitem>
10491046

@@ -1072,6 +1069,8 @@ CREATE TRIGGER test_valid_id_trig
10721069
</listitem>
10731070
</itemizedlist>
10741071
</para>
1072+
</sect2>
1073+
10751074
</sect1>
10761075

10771076
</chapter>

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

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -563,6 +563,17 @@ $$ LANGUAGE plperl;
563563
NOTICE: This is a test
564564
CONTEXT: PL/Perl anonymous code block
565565
-- check that restricted operations are rejected in a plperl DO block
566-
DO $$ use Config; $$ LANGUAGE plperl;
567-
ERROR: 'require' trapped by operation mask at line 1.
566+
DO $$ eval "1+1"; $$ LANGUAGE plperl;
567+
ERROR: 'eval "string"' trapped by operation mask at line 1.
568+
CONTEXT: PL/Perl anonymous code block
569+
-- check that we can't "use" a module that's not been loaded already
570+
-- compile-time error: "Unable to load blib.pm into plperl"
571+
DO $$ use blib; $$ LANGUAGE plperl;
572+
ERROR: Unable to load blib.pm into plperl at line 1.
573+
BEGIN failed--compilation aborted at line 1.
574+
CONTEXT: PL/Perl anonymous code block
575+
-- check that we can "use" a module that has already been loaded
576+
-- runtime error: "Can't use string ("foo") as a SCALAR ref while "strict refs" in use
577+
DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
578+
ERROR: Can't use string ("foo") as a SCALAR ref while "strict refs" in use at line 1.
568579
CONTEXT: PL/Perl anonymous code block

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

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,19 @@
11
-- test plperl/plperlu interaction
2+
-- the language and call ordering of this test sequence is useful
23
CREATE OR REPLACE FUNCTION bar() RETURNS integer AS $$
34
#die 'BANG!'; # causes server process to exit(2)
45
# alternative - causes server process to exit(255)
56
spi_exec_query("invalid sql statement");
6-
$$ language plperl; -- plperl or plperlu
7+
$$ language plperl; -- compile plperl code
78

89
CREATE OR REPLACE FUNCTION foo() RETURNS integer AS $$
910
spi_exec_query("SELECT * FROM bar()");
1011
return 1;
11-
$$ LANGUAGE plperlu; -- must be opposite to language of bar
12+
$$ LANGUAGE plperlu; -- compile plperlu code
1213

13-
SELECT * FROM bar(); -- throws exception normally
14+
SELECT * FROM bar(); -- throws exception normally (running plperl)
1415
ERROR: syntax error at or near "invalid" at line 4.
1516
CONTEXT: PL/Perl function "bar"
16-
SELECT * FROM foo(); -- used to cause backend crash
17+
SELECT * FROM foo(); -- used to cause backend crash (after switching to plperlu)
1718
ERROR: syntax error at or near "invalid" at line 4. at line 2.
1819
CONTEXT: PL/Perl function "foo"

‎src/pl/plperl/plc_perlboot.pl

Lines changed: 18 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11

2-
# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
2+
# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
33

44
PostgreSQL::InServer::Util::bootstrap();
55
PostgreSQL::InServer::SPI::bootstrap();
@@ -21,17 +21,25 @@ sub ::plperl_die {
2121
}
2222
$SIG{__DIE__} = \&::plperl_die;
2323

24+
sub ::mkfuncsrc {
25+
my ($name, $imports, $prolog, $src) = @_;
2426

25-
sub ::mkunsafefunc {
26-
my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
27-
$@ =~ s/\(eval \d+\) //g if $@;
28-
return $ret;
27+
my $BEGIN = join "\n", map {
28+
my $names = $imports->{$_} || [];
29+
"$_->import(qw(@$names));"
30+
} sort keys %$imports;
31+
$BEGIN &&= "BEGIN { $BEGIN }";
32+
33+
$name =~ s/\\/\\\\/g;
34+
$name =~ s/::|'/_/g; # avoid package delimiters
35+
36+
return qq[ undef *{'$name'}; *{'$name'} = sub { $BEGIN $prolog $src } ];
2937
}
30-
31-
use strict;
3238

33-
sub ::mk_strict_unsafefunc {
34-
my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
39+
# see also mksafefunc() in plc_safe_ok.pl
40+
sub ::mkunsafefunc {
41+
no strict; # default to no strict for the eval
42+
my $ret = eval(::mkfuncsrc(@_));
3543
$@ =~ s/\(eval \d+\) //g if $@;
3644
return $ret;
3745
}
@@ -64,7 +72,7 @@ sub ::encode_array_constructor {
6472
if ref $arg ne 'ARRAY';
6573
my $res = join ", ", map {
6674
(ref $_) ? ::encode_array_constructor($_)
67-
: ::quote_nullable($_)
75+
: ::quote_nullable($_)
6876
} @$arg;
6977
return "ARRAY[$res]";
7078
}

‎src/pl/plperl/plc_safe_bad.pl

Lines changed: 11 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,16 @@
11

2-
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
2+
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
33

4-
use vars qw($PLContainer);
4+
# Minimal version of plc_safe_ok.pl
5+
# that's used if Safe is too old or doesn't load for any reason
56

6-
$PLContainer = new Safe('PLPerl');
7-
$PLContainer->permit_only(':default');
8-
$PLContainer->share(qw[&elog &ERROR]);
7+
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module';
98

10-
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
11-
sub ::mksafefunc {
12-
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
9+
sub mksafefunc {
10+
my ($name, $pragma, $prolog, $src) = @_;
11+
# replace $src with code to generate an error
12+
$src = qq{ ::elog(::ERROR,"$msg\n") };
13+
my $ret = eval(::mkfuncsrc($name, $pragma, '', $src));
14+
$@ =~ s/\(eval \d+\) //g if $@;
15+
return $ret;
1316
}
14-
15-
sub ::mk_strict_safefunc {
16-
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
17-
}
18-

‎src/pl/plperl/plc_safe_ok.pl

Lines changed: 19 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,13 @@
11

22

3-
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
3+
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.3 2010/01/26 23:11:56 adunstan Exp $
44

5+
use strict;
56
use vars qw($PLContainer);
67

78
$PLContainer = new Safe('PLPerl');
89
$PLContainer->permit_only(':default');
9-
$PLContainer->permit(qw[:base_math !:base_io sort time]);
10+
$PLContainer->permit(qw[:base_math !:base_io sort time require]);
1011

1112
$PLContainer->share(qw[&elog &return_next
1213
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
@@ -18,23 +19,24 @@
1819
&looks_like_number
1920
]);
2021

21-
# Load strict into the container.
22-
# The temporary enabling of the caller opcode here is to work around a
23-
# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
24-
# notice. It is quite safe, as caller is informational only, and in any case
25-
# we only enable it while we load the 'strict' module.
26-
$PLContainer->permit(qw[require caller]);
27-
$PLContainer->reval('use strict;');
28-
$PLContainer->deny(qw[require caller]);
29-
30-
sub ::mksafefunc {
31-
my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
22+
# Load widely useful pragmas into the container to make them available.
23+
# (Temporarily enable caller here as work around for bug in perl 5.10,
24+
# which changed the way its Safe.pm works. It is quite safe, as caller is
25+
# informational only.)
26+
$PLContainer->permit(qw[caller]);
27+
::safe_eval(q{
28+
require strict;
29+
require feature if $] >= 5.010000;
30+
1;
31+
}) or die $@;
32+
$PLContainer->deny(qw[caller]);
33+
34+
sub ::safe_eval {
35+
my $ret = $PLContainer->reval(shift);
3236
$@ =~ s/\(eval \d+\) //g if $@;
3337
return $ret;
3438
}
3539

36-
sub ::mk_strict_safefunc {
37-
my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
38-
$@ =~ s/\(eval \d+\) //g if $@;
39-
return $ret;
40+
sub ::mksafefunc {
41+
return ::safe_eval(::mkfuncsrc(@_));
4042
}

0 commit comments

Comments
 (0)