src/pl/plperl/plc_perlboot.pl

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