1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
# src/pl/plperl/plc_perlboot.pl
use 5.008001;
use vars qw(%_SHARED $_TD);
PostgreSQL::InServer::Util::bootstrap();
# globals
sub ::is_array_ref {
return ref($_[0]) =~ m/^(?:PostgreSQL::InServer::)?ARRAY$/;
}
sub ::encode_array_literal {
my ($arg, $delim) = @_;
return $arg unless(::is_array_ref($arg));
$delim = ', ' unless defined $delim;
my $res = '';
foreach my $elem (@$arg) {
$res .= $delim if length $res;
if (ref $elem) {
$res .= ::encode_array_literal($elem, $delim);
}
elsif (defined $elem) {
(my $str = $elem) =~ s/(["\\])/\\$1/g;
$res .= qq("$str");
}
else {
$res .= 'NULL';
}
}
return qq({$res});
}
sub ::encode_array_constructor {
my $arg = shift;
return ::quote_nullable($arg) unless ::is_array_ref($arg);
my $res = join ", ", map {
(ref $_) ? ::encode_array_constructor($_)
: ::quote_nullable($_)
} @$arg;
return "ARRAY[$res]";
}
{
package PostgreSQL::InServer;
use strict;
use warnings;
sub plperl_warn {
(my $msg = shift) =~ s/\(eval \d+\) //g;
chomp $msg;
&::elog(&::WARNING, $msg);
}
$SIG{__WARN__} = \&plperl_warn;
sub plperl_die {
(my $msg = shift) =~ s/\(eval \d+\) //g;
die $msg;
}
$SIG{__DIE__} = \&plperl_die;
sub mkfuncsrc {
my ($name, $imports, $prolog, $src) = @_;
my $BEGIN = join "\n", map {
my $names = $imports->{$_} || [];
"$_->import(qw(@$names));"
} sort keys %$imports;
$BEGIN &&= "BEGIN { $BEGIN }";
return qq[ package main; sub { $BEGIN $prolog $src } ];
}
sub mkfunc {
no strict; # default to no strict for the eval
no warnings; # default to no warnings for the eval
my $ret = eval(mkfuncsrc(@_));
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
1;
}
{
package PostgreSQL::InServer::ARRAY;
use strict;
use warnings;
use overload
'""'=>\&to_str,
'@{}'=>\&to_arr;
sub to_str {
my $self = shift;
return ::encode_typed_literal($self->{'array'}, $self->{'typeoid'});
}
sub to_arr {
return shift->{'array'};
}
1;
}
|
