mirror of https://github.com/postgres/postgres
- 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.
REL9_0_ALPHA4_BRANCH
Andrew Dunstan
16 years ago
parent
369494e41f
commit
a2b34b16be
@ -0,0 +1,50 @@ |
||||
SPI::bootstrap(); |
||||
use vars qw(%_SHARED); |
||||
|
||||
sub ::plperl_warn { |
||||
(my $msg = shift) =~ s/\(eval \d+\) //g; |
||||
&elog(&NOTICE, $msg); |
||||
} |
||||
$SIG{__WARN__} = \&::plperl_warn; |
||||
|
||||
sub ::plperl_die { |
||||
(my $msg = shift) =~ s/\(eval \d+\) //g; |
||||
die $msg; |
||||
} |
||||
$SIG{__DIE__} = \&::plperl_die; |
||||
|
||||
sub ::mkunsafefunc { |
||||
my $ret = eval(qq[ sub { $_[0] $_[1] } ]); |
||||
$@ =~ s/\(eval \d+\) //g if $@; |
||||
return $ret; |
||||
} |
||||
|
||||
use strict; |
||||
|
||||
sub ::mk_strict_unsafefunc { |
||||
my $ret = eval(qq[ sub { use strict; $_[0] $_[1] } ]); |
||||
$@ =~ s/\(eval \d+\) //g if $@; |
||||
return $ret; |
||||
} |
||||
|
||||
sub ::_plperl_to_pg_array { |
||||
my $arg = shift; |
||||
ref $arg eq 'ARRAY' || return $arg; |
||||
my $res = ''; |
||||
my $first = 1; |
||||
foreach my $elem (@$arg) { |
||||
$res .= ', ' unless $first; $first = undef; |
||||
if (ref $elem) { |
||||
$res .= _plperl_to_pg_array($elem); |
||||
} |
||||
elsif (defined($elem)) { |
||||
my $str = qq($elem); |
||||
$str =~ s/([\"\\])/\\$1/g; |
||||
$res .= qq(\"$str\"); |
||||
} |
||||
else { |
||||
$res .= 'NULL' ; |
||||
} |
||||
} |
||||
return qq({$res}); |
||||
} |
||||
@ -0,0 +1,15 @@ |
||||
use vars qw($PLContainer); |
||||
|
||||
$PLContainer = new Safe('PLPerl'); |
||||
$PLContainer->permit_only(':default'); |
||||
$PLContainer->share(qw[&elog &ERROR]); |
||||
|
||||
my $msg = 'trusted Perl functions disabled - please upgrade Perl Safe module to version 2.09 or later'; |
||||
sub ::mksafefunc { |
||||
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]); |
||||
} |
||||
|
||||
sub ::mk_strict_safefunc { |
||||
return $PLContainer->reval(qq[sub { elog(ERROR,'$msg') }]); |
||||
} |
||||
|
||||
@ -0,0 +1,33 @@ |
||||
use vars qw($PLContainer); |
||||
|
||||
$PLContainer = new Safe('PLPerl'); |
||||
$PLContainer->permit_only(':default'); |
||||
$PLContainer->permit(qw[:base_math !:base_io sort time]); |
||||
|
||||
$PLContainer->share(qw[&elog &return_next |
||||
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query |
||||
&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan |
||||
&_plperl_to_pg_array |
||||
&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED |
||||
]); |
||||
|
||||
# Load strict into the container. |
||||
# The temporary enabling of the caller opcode here is to work around a |
||||
# bug in perl 5.10, which unkindly changed the way its Safe.pm works, without |
||||
# notice. It is quite safe, as caller is informational only, and in any case |
||||
# we only enable it while we load the 'strict' module. |
||||
$PLContainer->permit(qw[require caller]); |
||||
$PLContainer->reval('use strict;'); |
||||
$PLContainer->deny(qw[require caller]); |
||||
|
||||
sub ::mksafefunc { |
||||
my $ret = $PLContainer->reval(qq[sub { $_[0] $_[1] }]); |
||||
$@ =~ s/\(eval \d+\) //g if $@; |
||||
return $ret; |
||||
} |
||||
|
||||
sub ::mk_strict_safefunc { |
||||
my $ret = $PLContainer->reval(qq[sub { BEGIN { strict->import(); } $_[0] $_[1] }]); |
||||
$@ =~ s/\(eval \d+\) //g if $@; |
||||
return $ret; |
||||
} |
||||
@ -0,0 +1,98 @@ |
||||
=head1 NAME |
||||
|
||||
text2macro.pl - convert text files into C string-literal macro definitions |
||||
|
||||
=head1 SYNOPSIS |
||||
|
||||
text2macro [options] file ... > output.h |
||||
|
||||
Options: |
||||
|
||||
--prefix=S - add prefix S to the names of the macros |
||||
--name=S - use S as the macro name (assumes only one file) |
||||
--strip=S - don't include lines that match perl regex S |
||||
|
||||
=head1 DESCRIPTION |
||||
|
||||
Reads one or more text files and outputs a corresponding series of C |
||||
pre-processor macro definitions. Each macro defines a string literal that |
||||
contains the contents of the corresponding text file. The basename of the text |
||||
file as capitalized and used as the name of the macro, along with an optional prefix. |
||||
|
||||
=cut |
||||
|
||||
use strict; |
||||
use warnings; |
||||
|
||||
use Getopt::Long; |
||||
|
||||
GetOptions( |
||||
'prefix=s' => \my $opt_prefix, |
||||
'name=s' => \my $opt_name, |
||||
'strip=s' => \my $opt_strip, |
||||
'selftest!' => sub { exit selftest() }, |
||||
) or exit 1; |
||||
|
||||
die "No text files specified" |
||||
unless @ARGV; |
||||
|
||||
print qq{ |
||||
/* |
||||
* DO NOT EDIT - THIS FILE IS AUTOGENERATED - CHANGES WILL BE LOST |
||||
* Written by $0 from @ARGV |
||||
*/ |
||||
}; |
||||
|
||||
for my $src_file (@ARGV) { |
||||
|
||||
(my $macro = $src_file) =~ s/ .*? (\w+) (?:\.\w+) $/$1/x; |
||||
|
||||
open my $src_fh, $src_file # not 3-arg form |
||||
or die "Can't open $src_file: $!"; |
||||
|
||||
printf qq{#define %s%s \\\n}, |
||||
$opt_prefix || '', |
||||
($opt_name) ? $opt_name : uc $macro; |
||||
while (<$src_fh>) { |
||||
chomp; |
||||
|
||||
next if $opt_strip and m/$opt_strip/o; |
||||
|
||||
# escape the text to suite C string literal rules |
||||
s/\\/\\\\/g; |
||||
s/"/\\"/g; |
||||
|
||||
printf qq{"%s\\n" \\\n}, $_; |
||||
} |
||||
print qq{""\n\n}; |
||||
} |
||||
|
||||
print "/* end */\n"; |
||||
|
||||
exit 0; |
||||
|
||||
|
||||
sub selftest { |
||||
my $tmp = "text2macro_tmp"; |
||||
my $string = q{a '' '\\'' "" "\\"" "\\\\" "\\\\n" b}; |
||||
|
||||
open my $fh, ">$tmp.pl" or die; |
||||
print $fh $string; |
||||
close $fh; |
||||
|
||||
system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die; |
||||
open $fh, ">>$tmp.c"; |
||||
print $fh "#include <stdio.h>\n"; |
||||
print $fh "int main() { puts(X); return 0; }\n"; |
||||
close $fh; |
||||
system("cat -n $tmp.c"); |
||||
|
||||
system("make $tmp") == 0 or die; |
||||
open $fh, "./$tmp |" or die; |
||||
my $result = <$fh>; |
||||
unlink <$tmp.*>; |
||||
|
||||
warn "Test string: $string\n"; |
||||
warn "Result : $result"; |
||||
die "Failed!" if $result ne "$string\n"; |
||||
} |
||||
Loading…
Reference in new issue