Adding upstream version 15.5.upstream/15.5

Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>

1 files changed, 129 insertions, 0 deletions

diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
new file mode 100644
index 0000000..8fd7f99
--- /dev/null
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -0,0 +1,129 @@
+
+# Copyright (c) 2021-2022, PostgreSQL Global Development Group
+
+#  src/pl/plperl/plc_perlboot.pl
+
+use strict;
+use warnings;
+
+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]";
+}
+
+{
+#<<< protect next line from perltidy so perlcritic annotation works
+	package PostgreSQL::InServer;  ## no critic (RequireFilenameMatchesPackage)
+#>>>
+	use strict;
+	use warnings;
+
+	sub plperl_warn
+	{
+		(my $msg = shift) =~ s/\(eval \d+\) //g;
+		chomp $msg;
+		&::elog(&::WARNING, $msg);
+		return;
+	}
+	$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 critic (ProhibitNoStrict, ProhibitStringyEval);
+		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;
+		## use critic
+	}
+
+	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;
+}