This is the first of the patches to be split out from the former 'plperl
feature patch 1'.
Changes in this patch:
- Added utility functions: quote_literal, quote_nullable, quote_ident,
encode_bytea, decode_bytea, looks_like_number,
encode_array_literal, encode_array_constructor.
- Stored procedure subs are now given names ($name__$oid).
This is invisible to PL/Perl stored procedures but makes
tools like Devel::NYTProf and Devel::Cover _much_ more useful.
- Warnings no longer have an extra newline in the NOTICE text.
- Corresponding documentation changes in plperl.sgml, plus:
Removed some trailing whitespace.
Made some examples use more idiomatic perl.
Added the missing ', arguments' to docs of spi_exec_prepared().
- Assorted minor changes
Various minor optimizations like pre-growing data structures.
Makes proper use of the recently updated ppport.h.
Tim.
diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 37114bd..94db722 100644
*** a/doc/src/sgml/plperl.sgml
--- b/doc/src/sgml/plperl.sgml
***************
*** 13,19 ****
<para>
PL/Perl is a loadable procedural language that enables you to write
! <productname>PostgreSQL</productname> functions in the
<ulink url="http://www.perl.org";>Perl programming language</ulink>.
</para>
--- 13,19 ----
<para>
PL/Perl is a loadable procedural language that enables you to write
! <productname>PostgreSQL</productname> functions in the
<ulink url="http://www.perl.org";>Perl programming language</ulink>.
</para>
*************** $$ LANGUAGE plperl;
*** 101,107 ****
linkend="sql-syntax-dollar-quoting">) for the string constant.
If you choose to use escape string syntax <literal>E''</>,
you must double the single quote marks (<literal>'</>) and backslashes
! (<literal>\</>) used in the body of the function
(see <xref linkend="sql-syntax-strings">).
</para>
--- 101,107 ----
linkend="sql-syntax-dollar-quoting">) for the string constant.
If you choose to use escape string syntax <literal>E''</>,
you must double the single quote marks (<literal>'</>) and backslashes
! (<literal>\</>) used in the body of the function
(see <xref linkend="sql-syntax-strings">).
</para>
*************** $$ LANGUAGE plperl;
*** 141,153 ****
<programlisting>
CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$
! my ($x,$y) = @_;
! if (! defined $x) {
! if (! defined $y) { return undef; }
return $y;
}
! if (! defined $y) { return $x; }
! if ($x > $y) { return $x; }
return $y;
$$ LANGUAGE plperl;
</programlisting>
--- 141,153 ----
<programlisting>
CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$
! my ($x, $y) = @_;
! if (not defined $x) {
! return undef if not defined $y;
return $y;
}
! return $x if not defined $y;
! return $x if $x > $y;
return $y;
$$ LANGUAGE plperl;
</programlisting>
*************** $$ LANGUAGE plperl;
*** 158,189 ****
<para>
Anything in a function argument that is not a reference is
! a string, which is in the standard <productname>PostgreSQL</productname>
external text representation for the relevant data type. In the case of
ordinary numeric or text types, Perl will just do the right thing and
the programmer will normally not have to worry about it. However, in
! other cases the argument will need to be converted into a form that is
! more usable in Perl. For example, here is how to convert an argument of
! type <type>bytea</> into unescaped binary
! data:
!
! <programlisting>
! my $arg = shift;
! $arg =~ s!\\(?:\\|(\d{3}))!$1 ? chr(oct($1)) : "\\"!ge;
! </programlisting>
!
</para>
<para>
! Similarly, values passed back to <productname>PostgreSQL</productname>
! must be in the external text representation format. For example, here
! is how to escape binary data for a return value of type <type>bytea</>:
!
! <programlisting>
! $retval =~ s!(\\|[^ -~])!sprintf("\\%03o",ord($1))!ge;
! return $retval;
! </programlisting>
!
</para>
<para>
--- 158,178 ----
<para>
Anything in a function argument that is not a reference is
! a string, which is in the standard <productname>PostgreSQL</productname>
external text representation for the relevant data type. In the case of
ordinary numeric or text types, Perl will just do the right thing and
the programmer will normally not have to worry about it. However, in
! other cases the argument will need to be converted into a form that is
! more usable in Perl. For example, the <function>decode_bytea</function>
! function can be used to convert an argument of
! type <type>bytea</> into unescaped binary.
</para>
<para>
! Similarly, values passed back to <productname>PostgreSQL</productname>
! must be in the external text representation format. For example, the
! <function>encode_bytea</function> function can be used to
! to escape binary data for a return value of type <type>bytea</>.
</para>
<para>
*************** BEGIN { strict->import(); }
*** 322,328 ****
</para>
</sect1>
! <sect1 id="plperl-database">
<title>Database Access from PL/Perl</title>
<para>
--- 311,320 ----
</para>
</sect1>
! <sect1 id="plperl-builtins">
! <title>Built-in Functions</title>
!
! <sect2 id="plperl-database">
<title>Database Access from PL/Perl</title>
<para>
*************** BEGIN { strict->import(); }
*** 340,346 ****
<term><literal><function>spi_query</>(<replaceable>command</replaceable>)</literal></term>
<term><literal><function>spi_fetchrow</>(<replaceable>cursor</replaceable>)</literal></term>
<term><literal><function>spi_prepare</>(<replaceable>command</replaceable>, <replaceable>argument types</replaceable>)</literal></term>
! <term><literal><function>spi_exec_prepared</>(<replaceable>plan</replaceable>)</literal></term>
<term><literal><function>spi_query_prepared</>(<replaceable>plan</replaceable> [, <replaceable>attributes</replaceable>], <replaceable>arguments</replaceable>)</literal></term>
<term><literal><function>spi_cursor_close</>(<replaceable>cursor</replaceable>)</literal></term>
<term><literal><function>spi_freeplan</>(<replaceable>plan</replaceable>)</literal></term>
--- 332,338 ----
<term><literal><function>spi_query</>(<replaceable>command</replaceable>)</literal></term>
<term><literal><function>spi_fetchrow</>(<replaceable>cursor</replaceable>)</literal></term>
<term><literal><function>spi_prepare</>(<replaceable>command</replaceable>, <replaceable>argument types</replaceable>)</literal></term>
! <term><literal><function>spi_exec_prepared</>(<replaceable>plan</replaceable>, <replaceable>arguments</replaceable>)</literal></term>
<term><literal><function>spi_query_prepared</>(<replaceable>plan</replaceable> [, <replaceable>attributes</replaceable>], <replaceable>arguments</replaceable>)</literal></term>
<term><literal><function>spi_cursor_close</>(<replaceable>cursor</replaceable>)</literal></term>
<term><literal><function>spi_freeplan</>(<replaceable>plan</replaceable>)</literal></term>
*************** $$ LANGUAGE plperlu;
*** 455,473 ****
SELECT * from lotsa_md5(500);
</programlisting>
</para>
!
<para>
! <literal>spi_prepare</literal>, <literal>spi_query_prepared</literal>, <literal>spi_exec_prepared</literal>,
and <literal>spi_freeplan</literal> implement the same functionality but for prepared queries. Once
a query plan is prepared by a call to <literal>spi_prepare</literal>, the plan can be used instead
of the string query, either in <literal>spi_exec_prepared</literal>, where the result is the same as returned
by <literal>spi_exec_query</literal>, or in <literal>spi_query_prepared</literal> which returns a cursor
exactly as <literal>spi_query</literal> does, which can be later passed to <literal>spi_fetchrow</literal>.
</para>
!
<para>
The advantage of prepared queries is that is it possible to use one prepared plan for more
! than one query execution. After the plan is not needed anymore, it can be freed with
<literal>spi_freeplan</literal>:
</para>
--- 447,465 ----
SELECT * from lotsa_md5(500);
</programlisting>
</para>
!
<para>
! <literal>spi_prepare</literal>, <literal>spi_query_prepared</literal>, <literal>spi_exec_prepared</literal>,
and <literal>spi_freeplan</literal> implement the same functionality but for prepared queries. Once
a query plan is prepared by a call to <literal>spi_prepare</literal>, the plan can be used instead
of the string query, either in <literal>spi_exec_prepared</literal>, where the result is the same as returned
by <literal>spi_exec_query</literal>, or in <literal>spi_query_prepared</literal> which returns a cursor
exactly as <literal>spi_query</literal> does, which can be later passed to <literal>spi_fetchrow</literal>.
</para>
!
<para>
The advantage of prepared queries is that is it possible to use one prepared plan for more
! than one query execution. After the plan is not needed anymore, it can be freed with
<literal>spi_freeplan</literal>:
</para>
*************** CREATE OR REPLACE FUNCTION init() RETURN
*** 478,484 ****
$$ LANGUAGE plperl;
CREATE OR REPLACE FUNCTION add_time( INTERVAL ) RETURNS TEXT AS $$
! return spi_exec_prepared(
$_SHARED{my_plan},
$_[0],
)->{rows}->[0]->{now};
--- 470,476 ----
$$ LANGUAGE plperl;
CREATE OR REPLACE FUNCTION add_time( INTERVAL ) RETURNS TEXT AS $$
! return spi_exec_prepared(
$_SHARED{my_plan},
$_[0],
)->{rows}->[0]->{now};
*************** SELECT init();
*** 493,499 ****
SELECT add_time('1 day'), add_time('2 days'), add_time('3 days');
SELECT done();
! add_time | add_time | add_time
------------+------------+------------
2005-12-10 | 2005-12-11 | 2005-12-12
</programlisting>
--- 485,491 ----
SELECT add_time('1 day'), add_time('2 days'), add_time('3 days');
SELECT done();
! add_time | add_time | add_time
------------+------------+------------
2005-12-10 | 2005-12-11 | 2005-12-12
</programlisting>
*************** SELECT done();
*** 516,522 ****
--- 508,520 ----
</para>
</listitem>
</varlistentry>
+ </variablelist>
+ </sect2>
+
+ <sect2 id="plperl-utility-functions">
+ <title>Utility functions in PL/Perl</title>
+ <variablelist>
<varlistentry>
<indexterm>
<primary>elog</primary>
*************** SELECT done();
*** 545,552 ****
--- 543,685 ----
</para>
</listitem>
</varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>quote_literal</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>quote_literal</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Return the given string suitably quoted to be used as a string literal in an SQL
+ statement string. Embedded single-quotes and backslashes are properly doubled.
+ Note that <function>quote_literal</> returns undef on undef input; if the argument
+ might be undef, <function>quote_nullable</> is often more suitable.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>quote_nullable</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>quote_nullable</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Return the given string suitably quoted to be used as a string literal in an SQL
+ statement string; or, if the argument is undef, return the unquoted string "NULL".
+ Embedded single-quotes and backslashes are properly doubled.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>quote_ident</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>quote_ident</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Return the given string suitably quoted to be used as an identifier in
+ an SQL statement string. Quotes are added only if necessary (i.e., if
+ the string contains non-identifier characters or would be case-folded).
+ Embedded quotes are properly doubled.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>decode_bytea</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>decode_bytea</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Return the unescaped binary data represented by the contents of the given string,
+ which should be bytea encoded.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>encode_bytea</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>encode_bytea</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Return the bytea encoded form of the binary data contents of the given string.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>encode_array_literal</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>encode_array_literal</>(<replaceable>array</replaceable>)</literal></term>
+ <term><literal><function>encode_array_literal</>(<replaceable>array</replaceable>, <replaceable>delimiter</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Returns the contents of the referenced array as a string in array literal format
+ (see <xref linkend="arrays-input">).
+ Returns the argument value unaltered if it's not a reference to an array.
+ The delimiter used between elements of the array literal defaults to "<literal>, </literal>"
+ if a delimiter is not specified or is undef.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>encode_array_constructor</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>encode_array_constructor</>(<replaceable>array</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Returns the contents of the referenced array as a string in array constructor format
+ (see <xref linkend="sql-syntax-array-constructors">).
+ Individual values are quoted using <function>quote_nullable</function>.
+ Returns the argument value, quoted using <function>quote_nullable</function>,
+ if it's not a reference to an array.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <indexterm>
+ <primary>looks_like_number</primary>
+ <secondary>in PL/Perl</secondary>
+ </indexterm>
+
+ <term><literal><function>looks_like_number</>(<replaceable>string</replaceable>)</literal></term>
+ <listitem>
+ <para>
+ Returns a true value if the content of the given string looks like a
+ number, according to Perl, returns false otherwise.
+ Returns undef if the argument is undef. Leading and trailing space is
+ ignored. <literal>Inf</> and <literal>Infinity</> are regarded as numbers.
+ </para>
+ </listitem>
+ </varlistentry>
+
</variablelist>
</para>
+ </sect2>
</sect1>
<sect1 id="plperl-data">
*************** CREATE OR REPLACE FUNCTION get_var(name
*** 587,593 ****
return $_SHARED{$_[0]};
$$ LANGUAGE plperl;
! SELECT set_var('sample', 'Hello, PL/Perl! How's tricks?');
SELECT get_var('sample');
</programlisting>
</para>
--- 720,726 ----
return $_SHARED{$_[0]};
$$ LANGUAGE plperl;
! SELECT set_var('sample', 'Hello, PL/Perl! How''s tricks?');
SELECT get_var('sample');
</programlisting>
</para>
*************** $$ LANGUAGE plperl;
*** 701,715 ****
However, not all installations are compiled with the requisite flags.
If <productname>PostgreSQL</> detects that this is the case then it will
not start a second interpreter, but instead create an error. In
! consequence, in such an installation, you cannot use both
<application>PL/PerlU</> and <application>PL/Perl</> in the same backend
! process. The remedy for this is to obtain a Perl installation created
! with the appropriate flags, namely either <literal>usemultiplicity</> or
! both <literal>usethreads</> and <literal>useithreads</>.
! For more details,see the <literal>perlembed</> manual page.
</para>
</note>
!
</sect1>
<sect1 id="plperl-triggers">
--- 834,849 ----
However, not all installations are compiled with the requisite flags.
If <productname>PostgreSQL</> detects that this is the case then it will
not start a second interpreter, but instead create an error. In
! consequence, in such an installation, you cannot use both
<application>PL/PerlU</> and <application>PL/Perl</> in the same backend
! process. The remedy for this is to obtain a Perl installation configured
! with the appropriate flags, namely either <literal>usemultiplicity</>
! or <literal>useithreads</>. <literal>usemultiplicity</> is preferred
! unless you actually need to use threads. For more details, see the
! <citerefentry><refentrytitle>perlembed</></citerefentry> man page.
</para>
</note>
!
</sect1>
<sect1 id="plperl-triggers">
*************** $$ LANGUAGE plperl;
*** 718,725 ****
<para>
PL/Perl can be used to write trigger functions. In a trigger function,
the hash reference <varname>$_TD</varname> contains information about the
! current trigger event. <varname>$_TD</> is a global variable,
! which gets a separate local value for each invocation of the trigger.
The fields of the <varname>$_TD</varname> hash reference are:
<variablelist>
--- 852,859 ----
<para>
PL/Perl can be used to write trigger functions. In a trigger function,
the hash reference <varname>$_TD</varname> contains information about the
! current trigger event. <varname>$_TD</> is a global variable,
! which gets a separate local value for each invocation of the trigger.
The fields of the <varname>$_TD</varname> hash reference are:
<variablelist>
*************** $$ LANGUAGE plperl;
*** 801,807 ****
<listitem>
<para>
Name of the table on which the trigger fired. This has been deprecated,
! and could be removed in a future release.
Please use $_TD->{table_name} instead.
</para>
</listitem>
--- 935,941 ----
<listitem>
<para>
Name of the table on which the trigger fired. This has been deprecated,
! and could be removed in a future release.
Please use $_TD->{table_name} instead.
</para>
</listitem>
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index 43b0fd0..7cd5721 100644
*** a/src/pl/plperl/GNUmakefile
--- b/src/pl/plperl/GNUmakefile
*************** rpathdir = $(perl_archlibexp)/CORE
*** 34,47 ****
NAME = plperl
! OBJS = plperl.o spi_internal.o SPI.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
# if Perl can support two interpreters in one backend,
# test plperl-and-plperlu cases
ifneq ($(PERL),)
--- 34,47 ----
NAME = plperl
! 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 plperl_util plperlu
# if Perl can support two interpreters in one backend,
# test plperl-and-plperlu cases
ifneq ($(PERL),)
*************** all: all-lib
*** 65,70 ****
--- 65,73 ----
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
*************** submake:
*** 79,85 ****
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
! rm -f SPI.c $(OBJS) perlchunks.htmp perlchunks.h
rm -rf results
rm -f regression.diffs regression.out
--- 82,88 ----
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib
! rm -f SPI.c Util.c $(OBJS) perlchunks.htmp 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 967ac0a..af71414 100644
*** a/src/pl/plperl/SPI.xs
--- b/src/pl/plperl/SPI.xs
***************
*** 8,47 ****
/*
- * 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
--- 8,13 ----
*************** do_plperl_return_next(SV *sv)
*** 69,108 ****
}
! MODULE = 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;
--- 35,45 ----
}
! MODULE = PostgreSQL::InServer::SPI PREFIX = spi_
PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE
SV*
spi_spi_exec_query(query, ...)
char* query;
diff --git a/src/pl/plperl/Util.xs b/src/pl/plperl/Util.xs
index ...acfd59e .
*** a/src/pl/plperl/Util.xs
--- b/src/pl/plperl/Util.xs
***************
*** 0 ****
--- 1,202 ----
+ /* vim: et:sw=4
+ *
+ * PostgreSQL::InServer::Util
+ *
+ * Defines interfaces for general-purpose utilities.
+ * This module is bootstrapped as soon as an interpreter is initialized.
+ * (The SPI module is bootstrapped after the plperl.on_*_init code has run.)
+ * 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 1791d3c..89497e3 100644
*** a/src/pl/plperl/expected/plperl_elog.out
--- b/src/pl/plperl/expected/plperl_elog.out
*************** create or replace function perl_warn(tex
*** 21,27 ****
$$;
select perl_warn('implicit elog via warn');
NOTICE: implicit elog via warn at line 4.
-
CONTEXT: PL/Perl function "perl_warn"
perl_warn
-----------
--- 21,26 ----
diff --git a/src/pl/plperl/expected/plperl_util.out b/src/pl/plperl/expected/plperl_util.out
index ...6f16669 .
*** a/src/pl/plperl/expected/plperl_util.out
--- b/src/pl/plperl/expected/plperl_util.out
***************
*** 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...@}, q...@\x01@}, q...@\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 d2d5518..b4d1e04 100644
*** a/src/pl/plperl/plc_perlboot.pl
--- b/src/pl/plperl/plc_perlboot.pl
***************
*** 1,24 ****
! SPI::bootstrap();
use vars qw(%_SHARED);
sub ::plperl_warn {
(my $msg = shift) =~ s/\(eval \d+\) //g;
&elog(&NOTICE, $msg);
}
$SIG{__WARN__} = \&::plperl_warn;
sub ::plperl_die {
(my $msg = shift) =~ s/\(eval \d+\) //g;
! 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 {
--- 1,30 ----
! 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;
}
$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 {
*************** sub ::mk_strict_unsafefunc {
*** 27,50 ****
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});
}
--- 33,68 ----
return $ret;
}
! 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_ok.pl b/src/pl/plperl/plc_safe_ok.pl
index 73c5573..aec5cdc 100644
*** a/src/pl/plperl/plc_safe_ok.pl
--- b/src/pl/plperl/plc_safe_ok.pl
*************** $PLContainer->permit(qw[:base_math !:bas
*** 7,14 ****
$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
]);
# Load strict into the container.
--- 7,17 ----
$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
&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED
+ "e_literal "e_nullable "e_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 3fc992c..6f577f0 100644
*** a/src/pl/plperl/plperl.c
--- b/src/pl/plperl/plperl.c
*************** plperl_convert_to_pg_array(SV *src)
*** 589,600 ****
XPUSHs(src);
PUTBACK;
! count = call_pv("::_plperl_to_pg_array", G_SCALAR);
SPAGAIN;
if (count != 1)
! elog(ERROR, "unexpected _plperl_to_pg_array failure");
rv = POPs;
--- 589,600 ----
XPUSHs(src);
PUTBACK;
! count = perl_call_pv("::encode_array_literal", G_SCALAR);
SPAGAIN;
if (count != 1)
! elog(ERROR, "unexpected encode_array_literal failure");
rv = POPs;
*************** plperl_create_sub(plperl_proc_desc *prod
*** 1089,1095 ****
**********************************************************************/
EXTERN_C void boot_DynaLoader(pTHX_ CV *cv);
! EXTERN_C void boot_SPI(pTHX_ CV *cv);
static void
plperl_init_shared_libs(pTHX)
--- 1089,1096 ----
**********************************************************************/
EXTERN_C void boot_DynaLoader(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)
*************** plperl_init_shared_libs(pTHX)
*** 1097,1103 ****
char *file = __FILE__;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
! newXS("SPI::bootstrap", boot_SPI, file);
}
--- 1098,1107 ----
char *file = __FILE__;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, 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 b8d8c69..58dceef 100644
*** a/src/pl/plperl/plperl.h
--- b/src/pl/plperl/plperl.h
***************
*** 30,57 ****
#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 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 */
HV *plperl_spi_exec(char *, int);
void plperl_return_next(SV *);
SV *plperl_spi_query(char *);
--- 30,48 ----
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
! /* 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
! /* 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
index 1bb82b0..e69de29 100644
*** a/src/pl/plperl/spi_internal.c
--- b/src/pl/plperl/spi_internal.c
***************
*** 1,51 ****
- /*
- * $PostgreSQL$
- *
- *
- * 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;
- }
--- 0 ----
diff --git a/src/pl/plperl/sql/plperl_util.sql b/src/pl/plperl/sql/plperl_util.sql
index ...6a810d8 .
*** a/src/pl/plperl/sql/plperl_util.sql
--- b/src/pl/plperl/sql/plperl_util.sql
***************
*** 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...@}, q...@\x01@}, q...@\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();
--
Sent via pgsql-hackers mailing list (pgsql-hackers@postgresql.org)
To make changes to your subscription:
http://www.postgresql.org/mailpref/pgsql-hackers
