Skip to content

Commit a2b34b1

Browse files
adunstanadunstan
committed
Tidy up and refactor plperl.c.
- Changed MULTIPLICITY check from runtime to compiletime. No loads the large Config module. - Changed plperl_init_interp() to return new interp and not alter the global interp_state - Moved plperl_safe_init() call into check_interp(). - Removed plperl_safe_init_done state variable as interp_state now covers that role. - Changed plperl_create_sub() to take a plperl_proc_desc argument. - Simplified return value handling in plperl_create_sub. - Changed perl.com link in the docs to perl.org and tweaked wording to clarify that require, not use, is what's blocked. - Moved perl code in large multi-line C string literal macros out to plc_*.pl files. - Added a test2macro.pl utility to convert the plc_*.pl files to macros in a perlchunks.h file which is #included - Simplifed plperl_safe_init() slightly - Optimized pg_verifymbstr calls to avoid unneeded strlen()s. Patch from Tim Bunce, with minor editing from me.
1 parent 369494e commit a2b34b1

File tree

8 files changed

+303
-201
lines changed

8 files changed

+303
-201
lines changed

‎doc/src/sgml/plperl.sgml

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.71 2009/11/29 03:02:27 tgl Exp $ -->
1+
<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.72 2010/01/09 02:40:50 adunstan Exp $ -->
22

33
<chapter id="plperl">
44
<title>PL/Perl - Perl Procedural Language</title>
@@ -14,7 +14,7 @@
1414
<para>
1515
PL/Perl is a loadable procedural language that enables you to write
1616
<productname>PostgreSQL</productname> functions in the
17-
<ulink url="http://www.perl.com">Perl programming language</ulink>.
17+
<ulink url="http://www.perl.org">Perl programming language</ulink>.
1818
</para>
1919

2020
<para>
@@ -313,7 +313,8 @@ SELECT * FROM perl_set();
313313
use strict;
314314
</programlisting>
315315
in the function body. But this only works in <application>PL/PerlU</>
316-
functions, since <literal>use</> is not a trusted operation. In
316+
functions, since the <literal>use</> triggers a <literal>require</>
317+
which is not a trusted operation. In
317318
<application>PL/Perl</> functions you can instead do:
318319
<programlisting>
319320
BEGIN { strict->import(); }

‎src/pl/plperl/GNUmakefile

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
# Makefile for PL/Perl
2-
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.37 2009/06/05 18:29:56 adunstan Exp $
2+
# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.38 2010/01/09 02:40:50 adunstan Exp $
33

44
subdir = src/pl/plperl
55
top_builddir = ../../..
@@ -45,6 +45,11 @@ PSQLDIR = $(bindir)
4545

4646
include $(top_srcdir)/src/Makefile.shlib
4747

48+
plperl.o: perlchunks.h
49+
50+
perlchunks.h: plc_*.pl
51+
$(PERL) text2macro.pl --strip='^(\#.*|\s*)$$' plc_*.pl > perlchunks.htmp
52+
mv perlchunks.htmp perlchunks.h
4853

4954
all: all-lib
5055

@@ -65,7 +70,7 @@ submake:
6570
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
6671

6772
clean distclean maintainer-clean: clean-lib
68-
rm -f SPI.c $(OBJS)
73+
rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
6974
rm -rf results
7075
rm -f regression.diffs regression.out
7176

‎src/pl/plperl/plc_perlboot.pl

Lines changed: 50 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,50 @@
1+
SPI::bootstrap();
2+
use vars qw(%_SHARED);
3+
4+
sub ::plperl_warn {
5+
(my $msg = shift) =~ s/\(eval \d+\) //g;
6+
&elog(&NOTICE, $msg);
7+
}
8+
$SIG{__WARN__} = \&::plperl_warn;
9+
10+
sub ::plperl_die {
11+
(my $msg = shift) =~ s/\(eval \d+\) //g;
12+
die $msg;
13+
}
14+
$SIG{__DIE__} = \&::plperl_die;
15+
16+
sub ::mkunsafefunc {
17+
my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
18+
$@ =~ s/\(eval \d+\) //g if $@;
19+
return $ret;
20+
}
21+
22+
use strict;
23+
24+
sub ::mk_strict_unsafefunc {
25+
my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]);
26+
$@ =~ s/\(eval \d+\) //g if $@;
27+
return $ret;
28+
}
29+
30+
sub ::_plperl_to_pg_array {
31+
my $arg = shift;
32+
ref $arg eq 'ARRAY' || return $arg;
33+
my $res = '';
34+
my $first = 1;
35+
foreach my $elem (@$arg) {
36+
$res .= ', ' unless $first; $first = undef;
37+
if (ref $elem) {
38+
$res .= _plperl_to_pg_array($elem);
39+
}
40+
elsif (defined($elem)) {
41+
my $str = qq($elem);
42+
$str =~ s/([\"\\])/\\$1/g;
43+
$res .= qq(\"$str\");
44+
}
45+
else {
46+
$res .= 'NULL' ;
47+
}
48+
}
49+
return qq({$res});
50+
}

‎src/pl/plperl/plc_safe_bad.pl

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
use vars qw($PLContainer);
2+
3+
$PLContainer = new Safe('PLPerl');
4+
$PLContainer->permit_only(':default');
5+
$PLContainer->share(qw[&elog &ERROR]);
6+
7+
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later';
8+
sub ::mksafefunc {
9+
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
10+
}
11+
12+
sub ::mk_strict_safefunc {
13+
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]);
14+
}
15+

‎src/pl/plperl/plc_safe_ok.pl

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
use vars qw($PLContainer);
2+
3+
$PLContainer = new Safe('PLPerl');
4+
$PLContainer->permit_only(':default');
5+
$PLContainer->permit(qw[:base_math !:base_io sort time]);
6+
7+
$PLContainer->share(qw[&elog &return_next
8+
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
9+
&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
10+
&_plperl_to_pg_array
11+
&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
12+
]);
13+
14+
# Load strict into the container.
15+
# The temporary enabling of the caller opcode here is to work around a
16+
# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without
17+
# notice. It is quite safe, as caller is informational only, and in any case
18+
# we only enable it while we load the 'strict' module.
19+
$PLContainer->permit(qw[require caller]);
20+
$PLContainer->reval('use strict;');
21+
$PLContainer->deny(qw[require caller]);
22+
23+
sub ::mksafefunc {
24+
my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]);
25+
$@ =~ s/\(eval \d+\) //g if $@;
26+
return $ret;
27+
}
28+
29+
sub ::mk_strict_safefunc {
30+
my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]);
31+
$@ =~ s/\(eval \d+\) //g if $@;
32+
return $ret;
33+
}

0 commit comments

Comments
 (0)