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