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