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