aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/pl/plperl/GNUmakefile11
-rw-r--r--src/pl/plperl/SPI.xs74
-rw-r--r--src/pl/plperl/Util.xs205
-rw-r--r--src/pl/plperl/expected/plperl_elog.out1
-rw-r--r--src/pl/plperl/expected/plperl_util.out171
-rw-r--r--src/pl/plperl/plc_perlboot.pl67
-rw-r--r--src/pl/plperl/plc_safe_bad.pl3
-rw-r--r--src/pl/plperl/plc_safe_ok.pl9
-rw-r--r--src/pl/plperl/plperl.c14
-rw-r--r--src/pl/plperl/plperl.h23
-rw-r--r--src/pl/plperl/spi_internal.c51
-rw-r--r--src/pl/plperl/sql/plperl_util.sql100
-rw-r--r--src/pl/plperl/text2macro.pl3
13 files changed, 567 insertions, 165 deletions
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index 81c918a1d59..f794f028bec 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -1,5 +1,5 @@
# Makefile for PL/Perl
-# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.41 2010/01/10 18:10:03 tgl Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.42 2010/01/20 01:08:21 adunstan Exp $
subdir = src/pl/plperl
top_builddir = ../../..
@@ -34,14 +34,14 @@ rpathdir = $(perl_archlibexp)/CORE
NAME = plperl
-OBJS = plperl.o spi_internal.o SPI.o
+OBJS = plperl.o SPI.o Util.o
PERLCHUNKS = plc_perlboot.pl plc_safe_bad.pl plc_safe_ok.pl
SHLIB_LINK = $(perl_embed_ldflags)
REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu
-REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperlu
+REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperlu
# if Perl can support two interpreters in one backend,
# test plperl-and-plperlu cases
ifneq ($(PERL),)
@@ -64,6 +64,9 @@ all: all-lib
SPI.c: SPI.xs
$(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@
+Util.c: Util.xs
+ $(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@
+
install: all installdirs install-lib
installdirs: installdirs-lib
@@ -78,7 +81,7 @@ submake:
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
- rm -f SPI.c $(OBJS) perlchunks.h
+ rm -f SPI.c Util.c $(OBJS) perlchunks.h
rm -rf results
rm -f regression.diffs regression.out
diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs
index 967ac0adbab..9cee19a7f79 100644
--- a/src/pl/plperl/SPI.xs
+++ b/src/pl/plperl/SPI.xs
@@ -1,3 +1,12 @@
+/**********************************************************************
+ * PostgreSQL::InServer::SPI
+ *
+ * SPI interface for plperl.
+ *
+ * $PostgreSQL: pgsql/src/pl/plperl/SPI.xs,v 1.21 2010/01/20 01:08:21 adunstan Exp $
+ *
+ **********************************************************************/
+
/* this must be first: */
#include "postgres.h"
/* Defined by Perl */
@@ -8,40 +17,6 @@
/*
- * Implementation of plperl's elog() function
- *
- * If the error level is less than ERROR, we'll just emit the message and
- * return. When it is ERROR, elog() will longjmp, which we catch and
- * turn into a Perl croak(). Note we are assuming that elog() can't have
- * any internal failures that are so bad as to require a transaction abort.
- *
- * This is out-of-line to suppress "might be clobbered by longjmp" warnings.
- */
-static void
-do_spi_elog(int level, char *message)
-{
- MemoryContext oldcontext = CurrentMemoryContext;
-
- PG_TRY();
- {
- elog(level, "%s", message);
- }
- PG_CATCH();
- {
- ErrorData *edata;
-
- /* Must reset elog.c's state */
- MemoryContextSwitchTo(oldcontext);
- edata = CopyErrorData();
- FlushErrorState();
-
- /* Punt the error to Perl */
- croak("%s", edata->message);
- }
- PG_END_TRY();
-}
-
-/*
* Interface routine to catch ereports and punt them to Perl
*/
static void
@@ -69,40 +44,11 @@ do_plperl_return_next(SV *sv)
}
-MODULE = SPI PREFIX = spi_
+MODULE = PostgreSQL::InServer::SPI PREFIX = spi_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
-void
-spi_elog(level, message)
- int level
- char* message
- CODE:
- if (level > ERROR) /* no PANIC allowed thanks */
- level = ERROR;
- if (level < DEBUG5)
- level = DEBUG5;
- do_spi_elog(level, message);
-
-int
-spi_DEBUG()
-
-int
-spi_LOG()
-
-int
-spi_INFO()
-
-int
-spi_NOTICE()
-
-int
-spi_WARNING()
-
-int
-spi_ERROR()
-
SV*
spi_spi_exec_query(query, ...)
char* query;
diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs
new file mode 100644
index 00000000000..e77961698d8
--- /dev/null
+++ b/src/pl/plperl/Util.xs
@@ -0,0 +1,205 @@
+/**********************************************************************
+ * PostgreSQL::InServer::Util
+ *
+ * $PostgreSQL: pgsql/src/pl/plperl/Util.xs,v 1.1 2010/01/20 01:08:21 adunstan Exp $
+ *
+ * Defines plperl interfaces for general-purpose utilities.
+ * This module is bootstrapped as soon as an interpreter is initialized.
+ * Currently doesn't define a PACKAGE= so all subs are in main:: to avoid
+ * the need for explicit importing.
+ *
+ **********************************************************************/
+
+/* this must be first: */
+#include "postgres.h"
+#include "fmgr.h"
+#include "utils/builtins.h"
+#include "utils/bytea.h" /* for byteain & byteaout */
+#include "mb/pg_wchar.h" /* for GetDatabaseEncoding */
+/* Defined by Perl */
+#undef _
+
+/* perl stuff */
+#include "plperl.h"
+
+
+/*
+ * Implementation of plperl's elog() function
+ *
+ * If the error level is less than ERROR, we'll just emit the message and
+ * return. When it is ERROR, elog() will longjmp, which we catch and
+ * turn into a Perl croak(). Note we are assuming that elog() can't have
+ * any internal failures that are so bad as to require a transaction abort.
+ *
+ * This is out-of-line to suppress "might be clobbered by longjmp" warnings.
+ */
+static void
+do_util_elog(int level, char *message)
+{
+ MemoryContext oldcontext = CurrentMemoryContext;
+
+ PG_TRY();
+ {
+ elog(level, "%s", message);
+ }
+ PG_CATCH();
+ {
+ ErrorData *edata;
+
+ /* Must reset elog.c's state */
+ MemoryContextSwitchTo(oldcontext);
+ edata = CopyErrorData();
+ FlushErrorState();
+
+ /* Punt the error to Perl */
+ croak("%s", edata->message);
+ }
+ PG_END_TRY();
+}
+
+static SV *
+newSVstring_len(const char *str, STRLEN len)
+{
+ SV *sv;
+
+ sv = newSVpvn(str, len);
+#if PERL_BCDVERSION >= 0x5006000L
+ if (GetDatabaseEncoding() == PG_UTF8)
+ SvUTF8_on(sv);
+#endif
+ return sv;
+}
+
+static text *
+sv2text(SV *sv)
+{
+ STRLEN sv_len;
+ char *sv_pv;
+
+ if (!sv)
+ sv = &PL_sv_undef;
+ sv_pv = SvPV(sv, sv_len);
+ return cstring_to_text_with_len(sv_pv, sv_len);
+}
+
+MODULE = PostgreSQL::InServer::Util PREFIX = util_
+
+PROTOTYPES: ENABLE
+VERSIONCHECK: DISABLE
+
+int
+_aliased_constants()
+ PROTOTYPE:
+ ALIAS:
+ DEBUG = DEBUG2
+ LOG = LOG
+ INFO = INFO
+ NOTICE = NOTICE
+ WARNING = WARNING
+ ERROR = ERROR
+ CODE:
+ /* uses the ALIAS value as the return value */
+ RETVAL = ix;
+ OUTPUT:
+ RETVAL
+
+
+void
+util_elog(level, message)
+ int level
+ char* message
+ CODE:
+ if (level > ERROR) /* no PANIC allowed thanks */
+ level = ERROR;
+ if (level < DEBUG5)
+ level = DEBUG5;
+ do_util_elog(level, message);
+
+SV *
+util_quote_literal(sv)
+ SV *sv
+ CODE:
+ if (!sv || !SvOK(sv)) {
+ RETVAL = &PL_sv_undef;
+ }
+ else {
+ text *arg = sv2text(sv);
+ text *ret = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(arg)));
+ RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
+ }
+ OUTPUT:
+ RETVAL
+
+SV *
+util_quote_nullable(sv)
+ SV *sv
+ CODE:
+ if (!sv || !SvOK(sv))
+ {
+ RETVAL = newSVstring_len("NULL", 4);
+ }
+ else
+ {
+ text *arg = sv2text(sv);
+ text *ret = DatumGetTextP(DirectFunctionCall1(quote_nullable, PointerGetDatum(arg)));
+ RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
+ }
+ OUTPUT:
+ RETVAL
+
+SV *
+util_quote_ident(sv)
+ SV *sv
+ PREINIT:
+ text *arg;
+ text *ret;
+ CODE:
+ arg = sv2text(sv);
+ ret = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(arg)));
+ RETVAL = newSVstring_len(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
+ OUTPUT:
+ RETVAL
+
+SV *
+util_decode_bytea(sv)
+ SV *sv
+ PREINIT:
+ char *arg;
+ text *ret;
+ CODE:
+ arg = SvPV_nolen(sv);
+ ret = DatumGetTextP(DirectFunctionCall1(byteain, PointerGetDatum(arg)));
+ /* not newSVstring_len because this is raw bytes not utf8'able */
+ RETVAL = newSVpvn(VARDATA(ret), (VARSIZE(ret) - VARHDRSZ));
+ OUTPUT:
+ RETVAL
+
+SV *
+util_encode_bytea(sv)
+ SV *sv
+ PREINIT:
+ text *arg;
+ char *ret;
+ CODE:
+ arg = sv2text(sv);
+ ret = DatumGetCString(DirectFunctionCall1(byteaout, PointerGetDatum(arg)));
+ RETVAL = newSVstring_len(ret, strlen(ret));
+ OUTPUT:
+ RETVAL
+
+SV *
+looks_like_number(sv)
+ SV *sv
+ CODE:
+ if (!SvOK(sv))
+ RETVAL = &PL_sv_undef;
+ else if ( looks_like_number(sv) )
+ RETVAL = &PL_sv_yes;
+ else
+ RETVAL = &PL_sv_no;
+ OUTPUT:
+ RETVAL
+
+
+BOOT:
+ items = 0; /* avoid 'unused variable' warning */
diff --git a/src/pl/plperl/expected/plperl_elog.out b/src/pl/plperl/expected/plperl_elog.out
index 1791d3cc314..89497e3236d 100644
--- a/src/pl/plperl/expected/plperl_elog.out
+++ b/src/pl/plperl/expected/plperl_elog.out
@@ -21,7 +21,6 @@ create or replace function perl_warn(text) returns void language plperl as $$
$$;
select perl_warn('implicit elog via warn');
NOTICE: implicit elog via warn at line 4.
-
CONTEXT: PL/Perl function "perl_warn"
perl_warn
-----------
diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out
new file mode 100644
index 00000000000..6f16669b261
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_util.out
@@ -0,0 +1,171 @@
+-- test plperl utility functions (defined in Util.xs)
+-- test quote_literal
+create or replace function perl_quote_literal() returns setof text language plperl as $$
+ return_next "undef: ".quote_literal(undef);
+ return_next sprintf"$_: ".quote_literal($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+ return undef;
+$$;
+select perl_quote_literal();
+ perl_quote_literal
+--------------------
+ undef:
+ foo: 'foo'
+ a'b: 'a''b'
+ a"b: 'a"b'
+ c''d: 'c''''d'
+ e\f: E'e\\f'
+ : ''
+(7 rows)
+
+-- test quote_nullable
+create or replace function perl_quote_nullable() returns setof text language plperl as $$
+ return_next "undef: ".quote_nullable(undef);
+ return_next sprintf"$_: ".quote_nullable($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+ return undef;
+$$;
+select perl_quote_nullable();
+ perl_quote_nullable
+---------------------
+ undef: NULL
+ foo: 'foo'
+ a'b: 'a''b'
+ a"b: 'a"b'
+ c''d: 'c''''d'
+ e\f: E'e\\f'
+ : ''
+(7 rows)
+
+-- test quote_ident
+create or replace function perl_quote_ident() returns setof text language plperl as $$
+ return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled
+ return_next "$_: ".quote_ident($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{};
+ return undef;
+$$;
+select perl_quote_ident();
+ perl_quote_ident
+------------------
+ undef: ""
+ foo: foo
+ a'b: "a'b"
+ a"b: "a""b"
+ c''d: "c''d"
+ e\f: "e\f"
+ g.h: "g.h"
+ : ""
+(8 rows)
+
+-- test decode_bytea
+create or replace function perl_decode_bytea() returns setof text language plperl as $$
+ return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled
+ return_next "$_: ".decode_bytea($_)
+ for q{foo}, q{a\047b}, q{};
+ return undef;
+$$;
+select perl_decode_bytea();
+ perl_decode_bytea
+-------------------
+ undef:
+ foo: foo
+ a\047b: a'b
+ :
+(4 rows)
+
+-- test encode_bytea
+create or replace function perl_encode_bytea() returns setof text language plperl as $$
+ return_next encode_bytea(undef); # generates undef warning if warnings enabled
+ return_next encode_bytea($_)
+ for q{@}, qq{@\x01@}, qq{@\x00@}, q{};
+ return undef;
+$$;
+select perl_encode_bytea();
+ perl_encode_bytea
+-------------------
+ \x
+ \x40
+ \x400140
+ \x400040
+ \x
+(5 rows)
+
+-- test encode_array_literal
+create or replace function perl_encode_array_literal() returns setof text language plperl as $$
+ return_next encode_array_literal(undef);
+ return_next encode_array_literal(0);
+ return_next encode_array_literal(42);
+ return_next encode_array_literal($_)
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return_next encode_array_literal($_,'|')
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return undef;
+$$;
+select perl_encode_array_literal();
+ perl_encode_array_literal
+---------------------------
+
+ 0
+ 42
+ {}
+ {"0"}
+ {"1", "2", "3", "4", "5"}
+ {{}}
+ {{"1", "2", {"3"}}, "4"}
+ {}
+ {"0"}
+ {"1"|"2"|"3"|"4"|"5"}
+ {{}}
+ {{"1"|"2"|{"3"}}|"4"}
+(13 rows)
+
+-- test encode_array_constructor
+create or replace function perl_encode_array_constructor() returns setof text language plperl as $$
+ return_next encode_array_constructor(undef);
+ return_next encode_array_constructor(0);
+ return_next encode_array_constructor(42);
+ return_next encode_array_constructor($_)
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return undef;
+$$;
+select perl_encode_array_constructor();
+ perl_encode_array_constructor
+-----------------------------------------
+ NULL
+ '0'
+ '42'
+ ARRAY[]
+ ARRAY['0']
+ ARRAY['1', '2', '3', '4', '5']
+ ARRAY[ARRAY[]]
+ ARRAY[ARRAY['1', '2', ARRAY['3']], '4']
+(8 rows)
+
+-- test looks_like_number
+create or replace function perl_looks_like_number() returns setof text language plperl as $$
+ return_next "undef is undef" if not defined looks_like_number(undef);
+ return_next quote_nullable($_).": ". (looks_like_number($_) ? "number" : "not number")
+ for 'foo', 0, 1, 1.3, '+3.e-4',
+ '42 x', # trailing garbage
+ '99 ', # trailing space
+ ' 99', # leading space
+ ' ', # only space
+ ''; # empty string
+ return undef;
+$$;
+select perl_looks_like_number();
+ perl_looks_like_number
+------------------------
+ undef is undef
+ 'foo': not number
+ '0': number
+ '1': number
+ '1.3': number
+ '+3.e-4': number
+ '42 x': not number
+ '99 ': number
+ ' 99': number
+ ' ': not number
+ '': not number
+(11 rows)
+
diff --git a/src/pl/plperl/plc_perlboot.pl b/src/pl/plperl/plc_perlboot.pl
index d2d55184766..29f7bed3dc4 100644
--- a/src/pl/plperl/plc_perlboot.pl
+++ b/src/pl/plperl/plc_perlboot.pl
@@ -1,24 +1,33 @@
-SPI::bootstrap();
+
+# $PostgreSQL: pgsql/src/pl/plperl/plc_perlboot.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+
+PostgreSQL::InServer::Util::bootstrap();
+PostgreSQL::InServer::SPI::bootstrap();
+
+use strict;
+use warnings;
use vars qw(%_SHARED);
sub ::plperl_warn {
(my $msg = shift) =~ s/\(eval \d+\) //g;
+ chomp $msg;
&elog(&NOTICE, $msg);
}
$SIG{__WARN__} = \&::plperl_warn;
sub ::plperl_die {
(my $msg = shift) =~ s/\(eval \d+\) //g;
- die $msg;
+ die $msg;
}
$SIG{__DIE__} = \&::plperl_die;
+
sub ::mkunsafefunc {
my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
$@ =~ s/\(eval \d+\) //g if $@;
return $ret;
}
-
+
use strict;
sub ::mk_strict_unsafefunc {
@@ -27,24 +36,36 @@ sub ::mk_strict_unsafefunc {
return $ret;
}
-sub ::_plperl_to_pg_array {
- my $arg = shift;
- ref $arg eq 'ARRAY' || return $arg;
- my $res = '';
- my $first = 1;
- foreach my $elem (@$arg) {
- $res .= ', ' unless $first; $first = undef;
- if (ref $elem) {
- $res .= _plperl_to_pg_array($elem);
- }
- elsif (defined($elem)) {
- my $str = qq($elem);
- $str =~ s/([\"\\])/\\$1/g;
- $res .= qq(\"$str\");
- }
- else {
- $res .= 'NULL' ;
- }
- }
- return qq({$res});
+sub ::encode_array_literal {
+ my ($arg, $delim) = @_;
+ return $arg
+ if ref $arg ne 'ARRAY';
+ $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)
+ if ref $arg ne 'ARRAY';
+ my $res = join ", ", map {
+ (ref $_) ? ::encode_array_constructor($_)
+ : ::quote_nullable($_)
+ } @$arg;
+ return "ARRAY[$res]";
}
+
diff --git a/src/pl/plperl/plc_safe_bad.pl b/src/pl/plperl/plc_safe_bad.pl
index 838ccc63af5..4193c818180 100644
--- a/src/pl/plperl/plc_safe_bad.pl
+++ b/src/pl/plperl/plc_safe_bad.pl
@@ -1,3 +1,6 @@
+
+# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+
use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl');
diff --git a/src/pl/plperl/plc_safe_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index 73c5573ba89..cc4d3bdc3fa 100644
--- a/src/pl/plperl/plc_safe_ok.pl
+++ b/src/pl/plperl/plc_safe_ok.pl
@@ -1,3 +1,7 @@
+
+
+# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+
use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl');
@@ -7,8 +11,11 @@ $PLContainer->permit(qw[:base_math !:base_io sort time]);
$PLContainer->share(qw[&elog &return_next
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
- &_plperl_to_pg_array
&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
+ &quote_literal &quote_nullable &quote_ident
+ &encode_bytea &decode_bytea
+ &encode_array_literal &encode_array_constructor
+ &looks_like_number
]);
# Load strict into the container.
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 1dd704ffd06..6daab687c3b 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -1,7 +1,7 @@
/**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.159 2010/01/09 02:40:50 adunstan Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.160 2010/01/20 01:08:21 adunstan Exp $
*
**********************************************************************/
@@ -589,12 +589,12 @@ plperl_convert_to_pg_array(SV *src)
XPUSHs(src);
PUTBACK;
- count = call_pv("::_plperl_to_pg_array", G_SCALAR);
+ count = perl_call_pv("::encode_array_literal", G_SCALAR);
SPAGAIN;
if (count != 1)
- elog(ERROR, "unexpected _plperl_to_pg_array failure");
+ elog(ERROR, "unexpected encode_array_literal failure");
rv = POPs;
@@ -1089,7 +1089,8 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s)
**********************************************************************/
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
-EXTERN_C void boot_SPI(pTHX_ CV *cv);
+EXTERN_C void boot_PostgreSQL__InServer__SPI(pTHX_ CV *cv);
+EXTERN_C void boot_PostgreSQL__InServer__Util(pTHX_ CV *cv);
static void
plperl_init_shared_libs(pTHX)
@@ -1097,7 +1098,10 @@ plperl_init_shared_libs(pTHX)
char *file = __FILE__;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
- newXS("SPI::bootstrap", boot_SPI, file);
+ newXS("PostgreSQL::InServer::SPI::bootstrap",
+ boot_PostgreSQL__InServer__SPI, file);
+ newXS("PostgreSQL::InServer::Util::bootstrap",
+ boot_PostgreSQL__InServer__Util, file);
}
diff --git a/src/pl/plperl/plperl.h b/src/pl/plperl/plperl.h
index ae1002cdd73..6d58f117ca1 100644
--- a/src/pl/plperl/plperl.h
+++ b/src/pl/plperl/plperl.h
@@ -8,7 +8,7 @@
* Portions Copyright (c) 1996-2010, PostgreSQL Global Development Group
* Portions Copyright (c) 1995, Regents of the University of California
*
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.h,v 1.10 2010/01/02 16:58:12 momjian Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.h,v 1.11 2010/01/20 01:08:21 adunstan Exp $
*/
#ifndef PL_PERL_H
@@ -30,28 +30,19 @@
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-#include "ppport.h"
-/* just in case these symbols aren't provided */
-#ifndef pTHX_
-#define pTHX_
-#define pTHX void
-#endif
+/* perl version and platform portability */
+#define NEED_eval_pv
+#define NEED_newRV_noinc
+#define NEED_sv_2pv_flags
+#include "ppport.h"
/* perl may have a different width of "bool", don't buy it */
#ifdef bool
#undef bool
#endif
-/* routines from spi_internal.c */
-int spi_DEBUG(void);
-int spi_LOG(void);
-int spi_INFO(void);
-int spi_NOTICE(void);
-int spi_WARNING(void);
-int spi_ERROR(void);
-
-/* routines from plperl.c */
+/* declare routines from plperl.c for access by .xs files */
HV *plperl_spi_exec(char *, int);
void plperl_return_next(SV *);
SV *plperl_spi_query(char *);
diff --git a/src/pl/plperl/spi_internal.c b/src/pl/plperl/spi_internal.c
deleted file mode 100644
index 5544fbf4617..00000000000
--- a/src/pl/plperl/spi_internal.c
+++ /dev/null
@@ -1,51 +0,0 @@
-/*
- * $PostgreSQL: pgsql/src/pl/plperl/spi_internal.c,v 1.10 2009/06/11 14:49:14 momjian Exp $
- *
- *
- * This kludge is necessary because of the conflicting
- * definitions of 'DEBUG' between postgres and perl.
- * we'll live.
- */
-
-#include "postgres.h"
-/* Defined by Perl */
-#undef _
-
-/* perl stuff */
-#include "plperl.h"
-
-int
-spi_DEBUG(void)
-{
- return DEBUG2;
-}
-
-int
-spi_LOG(void)
-{
- return LOG;
-}
-
-int
-spi_INFO(void)
-{
- return INFO;
-}
-
-int
-spi_NOTICE(void)
-{
- return NOTICE;
-}
-
-int
-spi_WARNING(void)
-{
- return WARNING;
-}
-
-int
-spi_ERROR(void)
-{
- return ERROR;
-}
diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql
new file mode 100644
index 00000000000..6a810d8dd28
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_util.sql
@@ -0,0 +1,100 @@
+-- test plperl utility functions (defined in Util.xs)
+
+-- test quote_literal
+
+create or replace function perl_quote_literal() returns setof text language plperl as $$
+ return_next "undef: ".quote_literal(undef);
+ return_next sprintf"$_: ".quote_literal($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+ return undef;
+$$;
+
+select perl_quote_literal();
+
+-- test quote_nullable
+
+create or replace function perl_quote_nullable() returns setof text language plperl as $$
+ return_next "undef: ".quote_nullable(undef);
+ return_next sprintf"$_: ".quote_nullable($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{};
+ return undef;
+$$;
+
+select perl_quote_nullable();
+
+-- test quote_ident
+
+create or replace function perl_quote_ident() returns setof text language plperl as $$
+ return_next "undef: ".quote_ident(undef); # generates undef warning if warnings enabled
+ return_next "$_: ".quote_ident($_)
+ for q{foo}, q{a'b}, q{a"b}, q{c''d}, q{e\f}, q{g.h}, q{};
+ return undef;
+$$;
+
+select perl_quote_ident();
+
+-- test decode_bytea
+
+create or replace function perl_decode_bytea() returns setof text language plperl as $$
+ return_next "undef: ".decode_bytea(undef); # generates undef warning if warnings enabled
+ return_next "$_: ".decode_bytea($_)
+ for q{foo}, q{a\047b}, q{};
+ return undef;
+$$;
+
+select perl_decode_bytea();
+
+-- test encode_bytea
+
+create or replace function perl_encode_bytea() returns setof text language plperl as $$
+ return_next encode_bytea(undef); # generates undef warning if warnings enabled
+ return_next encode_bytea($_)
+ for q{@}, qq{@\x01@}, qq{@\x00@}, q{};
+ return undef;
+$$;
+
+select perl_encode_bytea();
+
+-- test encode_array_literal
+
+create or replace function perl_encode_array_literal() returns setof text language plperl as $$
+ return_next encode_array_literal(undef);
+ return_next encode_array_literal(0);
+ return_next encode_array_literal(42);
+ return_next encode_array_literal($_)
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return_next encode_array_literal($_,'|')
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return undef;
+$$;
+
+select perl_encode_array_literal();
+
+-- test encode_array_constructor
+
+create or replace function perl_encode_array_constructor() returns setof text language plperl as $$
+ return_next encode_array_constructor(undef);
+ return_next encode_array_constructor(0);
+ return_next encode_array_constructor(42);
+ return_next encode_array_constructor($_)
+ for [], [0], [1..5], [[]], [[1,2,[3]],4];
+ return undef;
+$$;
+
+select perl_encode_array_constructor();
+
+-- test looks_like_number
+
+create or replace function perl_looks_like_number() returns setof text language plperl as $$
+ return_next "undef is undef" if not defined looks_like_number(undef);
+ return_next quote_nullable($_).": ". (looks_like_number($_) ? "number" : "not number")
+ for 'foo', 0, 1, 1.3, '+3.e-4',
+ '42 x', # trailing garbage
+ '99 ', # trailing space
+ ' 99', # leading space
+ ' ', # only space
+ ''; # empty string
+ return undef;
+$$;
+
+select perl_looks_like_number();
diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
index 1628e8688d8..7e13ea5b276 100644
--- a/src/pl/plperl/text2macro.pl
+++ b/src/pl/plperl/text2macro.pl
@@ -1,3 +1,6 @@
+
+# $PostgreSQL: pgsql/src/pl/plperl/text2macro.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
+
=head1 NAME
text2macro.pl - convert text files into C string-literal macro definitions
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-24 23:04:27 +0000