src/pl/plperl/plc_perlboot.pl

   1
   2 # Copyright (c) 2021, PostgreSQL Global Development Group
   3
   4 #  src/pl/plperl/plc_perlboot.pl
   5
   6 use strict;
   7 use warnings;
   8
   9 use 5.008001;
  10 use vars qw(%_SHARED $_TD);
  11
  12 PostgreSQL::InServer::Util::bootstrap();
  13
  14 # globals
  15
  16 sub ::is_array_ref
  17 {
  18         return ref($_[0]) =~ m/^(?:PostgreSQL::InServer::)?ARRAY$/;
  19 }
  20
  21 sub ::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
  47 sub ::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 }