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