Skip to content

P
Postgres FD Implementation
Commit 05672e50 authored by Andrew Dunstan's avatar Andrew Dunstan
Browse files
Options

Add utility functions to PLPerl: 

    quote_literal, quote_nullable, quote_ident,
    encode_bytea, decode_bytea, looks_like_number,
    encode_array_literal, encode_array_constructor.
Split SPI.xs into two - SPI.xs now contains only SPI functions. Remainder
are in new Util.xs.
Some more code and documentation cleanup along the way, as well as
adding some CVS markers to files missing them.

Original patch from Tim Bunce, with a little editing from me.
parent 5b13d1ff
Hide whitespace changes
Inline Side-by-side
Showing with 747 additions and 211 deletions
doc/src/sgml/plperl.sgml
View file @ 05672e50
<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.72 2010/01/09 02:40:50 adunstan Exp $ --> <!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.73 2010/01/20 01:08:21 adunstan Exp $ -->
<chapter id="plperl"> <chapter id="plperl">
<title>PL/Perl - Perl Procedural Language</title> <title>PL/Perl - Perl Procedural Language</title>
...@@ -13,7 +13,7 @@ ...@@ -13,7 +13,7 @@
<para> <para>
PL/Perl is a loadable procedural language that enables you to write PL/Perl is a loadable procedural language that enables you to write
<productname>PostgreSQL</productname> functions in the <productname>PostgreSQL</productname> functions in the
<ulink url="http://www.perl.org">Perl programming language</ulink>. <ulink url="http://www.perl.org">Perl programming language</ulink>.
</para> </para>
...@@ -101,7 +101,7 @@ $$ LANGUAGE plperl; ...@@ -101,7 +101,7 @@ $$ LANGUAGE plperl;
linkend="sql-syntax-dollar-quoting">) for the string constant. linkend="sql-syntax-dollar-quoting">) for the string constant.
If you choose to use escape string syntax <literal>E''</>, If you choose to use escape string syntax <literal>E''</>,
you must double the single quote marks (<literal>'</>) and backslashes you must double the single quote marks (<literal>'</>) and backslashes
(<literal>\</>) used in the body of the function (<literal>\</>) used in the body of the function
(see <xref linkend="sql-syntax-strings">). (see <xref linkend="sql-syntax-strings">).
</para> </para>
...@@ -141,13 +141,13 @@ $$ LANGUAGE plperl; ...@@ -141,13 +141,13 @@ $$ LANGUAGE plperl;
<programlisting> <programlisting>
CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$ CREATE FUNCTION perl_max (integer, integer) RETURNS integer AS $$
my ($x,$y) = @_; my ($x, $y) = @_;
if (! defined $x) { if (not defined $x) {
if (! defined $y) { return undef; } return undef if not defined $y;
return $y; return $y;
} }
if (! defined $y) { return $x; } return $x if not defined $y;
if ($x &gt; $y) { return $x; } return $x if $x &gt; $y;
return $y; return $y;
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
</programlisting> </programlisting>
...@@ -158,32 +158,21 @@ $$ LANGUAGE plperl; ...@@ -158,32 +158,21 @@ $$ LANGUAGE plperl;
<para> <para>
Anything in a function argument that is not a reference is Anything in a function argument that is not a reference is
a string, which is in the standard <productname>PostgreSQL</productname> a string, which is in the standard <productname>PostgreSQL</productname>
external text representation for the relevant data type. In the case of 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 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 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 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 more usable in Perl. For example, the <function>decode_bytea</function>
type <type>bytea</> into unescaped binary function can be used to convert an argument of
data: type <type>bytea</> into unescaped binary.
<programlisting>
my $arg = shift;
$arg =~ s!\\(?:\\|(\d{3}))!$1 ? chr(oct($1)) : "\\"!ge;
</programlisting>
</para> </para>
<para> <para>
Similarly, values passed back to <productname>PostgreSQL</productname> Similarly, values passed back to <productname>PostgreSQL</productname>
must be in the external text representation format. For example, here must be in the external text representation format. For example, the
is how to escape binary data for a return value of type <type>bytea</>: <function>encode_bytea</function> function can be used to
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>
<para> <para>
...@@ -322,7 +311,10 @@ BEGIN { strict->import(); } ...@@ -322,7 +311,10 @@ BEGIN { strict->import(); }
</para> </para>
</sect1> </sect1>
<sect1 id="plperl-database"> <sect1 id="plperl-builtins">
<title>Built-in Functions</title>
<sect2 id="plperl-database">
<title>Database Access from PL/Perl</title> <title>Database Access from PL/Perl</title>
<para> <para>
...@@ -340,7 +332,7 @@ BEGIN { strict->import(); } ...@@ -340,7 +332,7 @@ BEGIN { strict->import(); }
<term><literal><function>spi_query</>(<replaceable>command</replaceable>)</literal></term> <term><literal><function>spi_query</>(<replaceable>command</replaceable>)</literal></term>
<term><literal><function>spi_fetchrow</>(<replaceable>cursor</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_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_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_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_cursor_close</>(<replaceable>cursor</replaceable>)</literal></term>
<term><literal><function>spi_freeplan</>(<replaceable>plan</replaceable>)</literal></term> <term><literal><function>spi_freeplan</>(<replaceable>plan</replaceable>)</literal></term>
...@@ -455,19 +447,19 @@ $$ LANGUAGE plperlu; ...@@ -455,19 +447,19 @@ $$ LANGUAGE plperlu;
SELECT * from lotsa_md5(500); SELECT * from lotsa_md5(500);
</programlisting> </programlisting>
</para> </para>
<para> <para>
<literal>spi_prepare</literal>, <literal>spi_query_prepared</literal>, <literal>spi_exec_prepared</literal>, <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 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 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 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 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>. exactly as <literal>spi_query</literal> does, which can be later passed to <literal>spi_fetchrow</literal>.
</para> </para>
<para> <para>
The advantage of prepared queries is that is it possible to use one prepared plan for more 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 than one query execution. After the plan is not needed anymore, it can be freed with
<literal>spi_freeplan</literal>: <literal>spi_freeplan</literal>:
</para> </para>
...@@ -478,7 +470,7 @@ CREATE OR REPLACE FUNCTION init() RETURNS INTEGER AS $$ ...@@ -478,7 +470,7 @@ CREATE OR REPLACE FUNCTION init() RETURNS INTEGER AS $$
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
CREATE OR REPLACE FUNCTION add_time( INTERVAL ) RETURNS TEXT AS $$ CREATE OR REPLACE FUNCTION add_time( INTERVAL ) RETURNS TEXT AS $$
return spi_exec_prepared( return spi_exec_prepared(
$_SHARED{my_plan}, $_SHARED{my_plan},
$_[0], $_[0],
)->{rows}->[0]->{now}; )->{rows}->[0]->{now};
...@@ -493,7 +485,7 @@ SELECT init(); ...@@ -493,7 +485,7 @@ SELECT init();
SELECT add_time('1 day'), add_time('2 days'), add_time('3 days'); SELECT add_time('1 day'), add_time('2 days'), add_time('3 days');
SELECT done(); SELECT done();
add_time | add_time | add_time add_time | add_time | add_time
------------+------------+------------ ------------+------------+------------
2005-12-10 | 2005-12-11 | 2005-12-12 2005-12-10 | 2005-12-11 | 2005-12-12
</programlisting> </programlisting>
...@@ -516,7 +508,13 @@ SELECT done(); ...@@ -516,7 +508,13 @@ SELECT done();
</para> </para>
</listitem> </listitem>
</varlistentry> </varlistentry>
</variablelist>
</sect2>
<sect2 id="plperl-utility-functions">
<title>Utility functions in PL/Perl</title>
<variablelist>
<varlistentry> <varlistentry>
<indexterm> <indexterm>
<primary>elog</primary> <primary>elog</primary>
...@@ -545,8 +543,143 @@ SELECT done(); ...@@ -545,8 +543,143 @@ SELECT done();
</para> </para>
</listitem> </listitem>
</varlistentry> </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> </variablelist>
</para> </para>
</sect2>
</sect1> </sect1>
<sect1 id="plperl-data"> <sect1 id="plperl-data">
...@@ -587,7 +720,7 @@ CREATE OR REPLACE FUNCTION get_var(name text) RETURNS text AS $$ ...@@ -587,7 +720,7 @@ CREATE OR REPLACE FUNCTION get_var(name text) RETURNS text AS $$
return $_SHARED{$_[0]}; return $_SHARED{$_[0]};
$$ LANGUAGE plperl; $$ LANGUAGE plperl;
SELECT set_var('sample', 'Hello, PL/Perl! How's tricks?'); SELECT set_var('sample', 'Hello, PL/Perl! How''s tricks?');
SELECT get_var('sample'); SELECT get_var('sample');
</programlisting> </programlisting>
</para> </para>
...@@ -701,15 +834,16 @@ $$ LANGUAGE plperl; ...@@ -701,15 +834,16 @@ $$ LANGUAGE plperl;
However, not all installations are compiled with the requisite flags. However, not all installations are compiled with the requisite flags.
If <productname>PostgreSQL</> detects that this is the case then it will If <productname>PostgreSQL</> detects that this is the case then it will
not start a second interpreter, but instead create an error. In not start a second interpreter, but instead create an error. In
consequence, in such an installation, you cannot use both consequence, in such an installation, you cannot use both
<application>PL/PerlU</> and <application>PL/Perl</> in the same backend <application>PL/PerlU</> and <application>PL/Perl</> in the same backend
process. The remedy for this is to obtain a Perl installation created process. The remedy for this is to obtain a Perl installation configured
with the appropriate flags, namely either <literal>usemultiplicity</> or with the appropriate flags, namely either <literal>usemultiplicity</>
both <literal>usethreads</> and <literal>useithreads</>. or <literal>useithreads</>. <literal>usemultiplicity</> is preferred
For more details,see the <literal>perlembed</> manual page. unless you actually need to use threads. For more details, see the
<citerefentry><refentrytitle>perlembed</></citerefentry> man page.
</para> </para>
</note> </note>
</sect1> </sect1>
<sect1 id="plperl-triggers"> <sect1 id="plperl-triggers">
...@@ -718,8 +852,8 @@ $$ LANGUAGE plperl; ...@@ -718,8 +852,8 @@ $$ LANGUAGE plperl;
<para> <para>
PL/Perl can be used to write trigger functions. In a trigger function, PL/Perl can be used to write trigger functions. In a trigger function,
the hash reference <varname>$_TD</varname> contains information about the the hash reference <varname>$_TD</varname> contains information about the
current trigger event. <varname>$_TD</> is a global variable, current trigger event. <varname>$_TD</> is a global variable,
which gets a separate local value for each invocation of the trigger. which gets a separate local value for each invocation of the trigger.
The fields of the <varname>$_TD</varname> hash reference are: The fields of the <varname>$_TD</varname> hash reference are:
<variablelist> <variablelist>
...@@ -801,7 +935,7 @@ $$ LANGUAGE plperl; ...@@ -801,7 +935,7 @@ $$ LANGUAGE plperl;
<listitem> <listitem>
<para> <para>
Name of the table on which the trigger fired. This has been deprecated, Name of the table on which the trigger fired. This has been deprecated,
and could be removed in a future release. and could be removed in a future release.
Please use $_TD-&gt;{table_name} instead. Please use $_TD-&gt;{table_name} instead.
</para> </para>
</listitem> </listitem>
......
src/pl/plperl/GNUmakefile
View file @ 05672e50
# Makefile for PL/Perl # 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 subdir = src/pl/plperl
top_builddir = ../../.. top_builddir = ../../..
...@@ -34,14 +34,14 @@ rpathdir = $(perl_archlibexp)/CORE ...@@ -34,14 +34,14 @@ rpathdir = $(perl_archlibexp)/CORE
NAME = plperl 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 PERLCHUNKS = plc_perlboot.pl plc_safe_bad.pl plc_safe_ok.pl
SHLIB_LINK = $(perl_embed_ldflags) SHLIB_LINK = $(perl_embed_ldflags)
REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl --load-language=plperlu 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, # if Perl can support two interpreters in one backend,
# test plperl-and-plperlu cases # test plperl-and-plperlu cases
ifneq ($(PERL),) ifneq ($(PERL),)
...@@ -64,6 +64,9 @@ all: all-lib ...@@ -64,6 +64,9 @@ all: all-lib
SPI.c: SPI.xs SPI.c: SPI.xs
$(PERL) $(perl_privlibexp)/ExtUtils/xsubpp -typemap $(perl_privlibexp)/ExtUtils/typemap $< >$@ $(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 install: all installdirs install-lib
installdirs: installdirs-lib installdirs: installdirs-lib
...@@ -78,7 +81,7 @@ submake: ...@@ -78,7 +81,7 @@ submake:
$(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X) $(MAKE) -C $(top_builddir)/src/test/regress pg_regress$(X)
clean distclean maintainer-clean: clean-lib 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 -rf results
rm -f regression.diffs regression.out rm -f regression.diffs regression.out
......
src/pl/plperl/SPI.xs
View file @ 05672e50
/**********************************************************************
* 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: */ /* this must be first: */
#include "postgres.h" #include "postgres.h"
/* Defined by Perl */ /* Defined by Perl */
...@@ -7,40 +16,6 @@ ...@@ -7,40 +16,6 @@
#include "plperl.h" #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_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 * Interface routine to catch ereports and punt them to Perl
*/ */
...@@ -69,40 +44,11 @@ do_plperl_return_next(SV *sv) ...@@ -69,40 +44,11 @@ do_plperl_return_next(SV *sv)
} }
MODULE = SPI PREFIX = spi_ MODULE = PostgreSQL::InServer::SPI PREFIX = spi_
PROTOTYPES: ENABLE PROTOTYPES: ENABLE
VERSIONCHECK: DISABLE 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* SV*
spi_spi_exec_query(query, ...) spi_spi_exec_query(query, ...)
char* query; char* query;
......
src/pl/plperl/Util.xs 0 → 100644
View file @ 05672e50
/**********************************************************************
* 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 */
src/pl/plperl/expected/plperl_elog.out
View file @ 05672e50
...@@ -21,7 +21,6 @@ create or replace function perl_warn(text) returns void language plperl as $$ ...@@ -21,7 +21,6 @@ create or replace function perl_warn(text) returns void language plperl as $$
$$; $$;
select perl_warn('implicit elog via warn'); select perl_warn('implicit elog via warn');
NOTICE: implicit elog via warn at line 4. NOTICE: implicit elog via warn at line 4.
CONTEXT: PL/Perl function "perl_warn" CONTEXT: PL/Perl function "perl_warn"
perl_warn perl_warn
----------- -----------
......
src/pl/plperl/expected/plperl_util.out 0 → 100644
View file @ 05672e50
-- 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)
src/pl/plperl/plc_perlboot.pl
View file @ 05672e50
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); use vars qw(%_SHARED);
sub ::plperl_warn { sub ::plperl_warn {
(my $msg = shift) =~ s/\(eval \d+\) //g; (my $msg = shift) =~ s/\(eval \d+\) //g;
chomp $msg;
&elog(&NOTICE, $msg); &elog(&NOTICE, $msg);
} }
$SIG{__WARN__} = \&::plperl_warn; $SIG{__WARN__} = \&::plperl_warn;
sub ::plperl_die { sub ::plperl_die {
(my $msg = shift) =~ s/\(eval \d+\) //g; (my $msg = shift) =~ s/\(eval \d+\) //g;
die $msg; die $msg;
} }
$SIG{__DIE__} = \&::plperl_die; $SIG{__DIE__} = \&::plperl_die;
sub ::mkunsafefunc { sub ::mkunsafefunc {
my $ret = eval(qq[ sub { $_[0] $_[1] } ]); my $ret = eval(qq[ sub { $_[0] $_[1] } ]);
$@ =~ s/\(eval \d+\) //g if $@; $@ =~ s/\(eval \d+\) //g if $@;
return $ret; return $ret;
} }
use strict; use strict;
sub ::mk_strict_unsafefunc { sub ::mk_strict_unsafefunc {
...@@ -27,24 +36,36 @@ sub ::mk_strict_unsafefunc { ...@@ -27,24 +36,36 @@ sub ::mk_strict_unsafefunc {
return $ret; return $ret;
} }
sub ::_plperl_to_pg_array { sub ::encode_array_literal {
my $arg = shift; my ($arg, $delim) = @_;
ref $arg eq 'ARRAY' || return $arg; return $arg
my $res = ''; if ref $arg ne 'ARRAY';
my $first = 1; $delim = ', ' unless defined $delim;
foreach my $elem (@$arg) { my $res = '';
$res .= ', ' unless $first; $first = undef; foreach my $elem (@$arg) {
if (ref $elem) { $res .= $delim if length $res;
$res .= _plperl_to_pg_array($elem); if (ref $elem) {
} $res .= ::encode_array_literal($elem, $delim);
elsif (defined($elem)) { }
my $str = qq($elem); elsif (defined $elem) {
$str =~ s/([\"\\])/\\$1/g; (my $str = $elem) =~ s/(["\\])/\\$1/g;
$res .= qq(\"$str\"); $res .= qq("$str");
} }
else { else {
$res .= 'NULL' ; $res .= 'NULL';
} }
} }
return qq({$res}); 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]";
} }
src/pl/plperl/plc_safe_bad.pl
View file @ 05672e50
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_bad.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
use vars qw($PLContainer); use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl'); $PLContainer = new Safe('PLPerl');
......
src/pl/plperl/plc_safe_ok.pl
View file @ 05672e50
# $PostgreSQL: pgsql/src/pl/plperl/plc_safe_ok.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
use vars qw($PLContainer); use vars qw($PLContainer);
$PLContainer = new Safe('PLPerl'); $PLContainer = new Safe('PLPerl');
...@@ -7,8 +11,11 @@ $PLContainer->permit(qw[:base_math !:base_io sort time]); ...@@ -7,8 +11,11 @@ $PLContainer->permit(qw[:base_math !:base_io sort time]);
$PLContainer->share(qw[&elog &return_next $PLContainer->share(qw[&elog &return_next
&spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query &spi_query &spi_fetchrow &spi_cursor_close &spi_exec_query
&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan &spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan
&_plperl_to_pg_array
&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED &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. # Load strict into the container.
......
src/pl/plperl/plperl.c
View file @ 05672e50
/********************************************************************** /**********************************************************************
* plperl.c - perl as a procedural language for PostgreSQL * 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) ...@@ -589,12 +589,12 @@ plperl_convert_to_pg_array(SV *src)
XPUSHs(src); XPUSHs(src);
PUTBACK; PUTBACK;
count = call_pv("::_plperl_to_pg_array", G_SCALAR); count = perl_call_pv("::encode_array_literal", G_SCALAR);
SPAGAIN; SPAGAIN;
if (count != 1) if (count != 1)
elog(ERROR, "unexpected _plperl_to_pg_array failure"); elog(ERROR, "unexpected encode_array_literal failure");
rv = POPs; rv = POPs;
...@@ -1089,7 +1089,8 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s) ...@@ -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_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 static void
plperl_init_shared_libs(pTHX) plperl_init_shared_libs(pTHX)
...@@ -1097,7 +1098,10 @@ plperl_init_shared_libs(pTHX) ...@@ -1097,7 +1098,10 @@ plperl_init_shared_libs(pTHX)
char *file = __FILE__; char *file = __FILE__;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, 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);
} }
......
src/pl/plperl/plperl.h
View file @ 05672e50
...@@ -8,7 +8,7 @@ ...@@ -8,7 +8,7 @@
* Portions Copyright (c) 1996-2010, PostgreSQL Global Development Group * Portions Copyright (c) 1996-2010, PostgreSQL Global Development Group
* Portions Copyright (c) 1995, Regents of the University of California * 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 #ifndef PL_PERL_H
...@@ -30,28 +30,19 @@ ...@@ -30,28 +30,19 @@
#include "EXTERN.h" #include "EXTERN.h"
#include "perl.h" #include "perl.h"
#include "XSUB.h" #include "XSUB.h"
#include "ppport.h"
/* just in case these symbols aren't provided */ /* perl version and platform portability */
#ifndef pTHX_ #define NEED_eval_pv
#define pTHX_ #define NEED_newRV_noinc
#define pTHX void #define NEED_sv_2pv_flags
#endif #include "ppport.h"
/* perl may have a different width of "bool", don't buy it */ /* perl may have a different width of "bool", don't buy it */
#ifdef bool #ifdef bool
#undef bool #undef bool
#endif #endif
/* routines from spi_internal.c */ /* declare routines from plperl.c for access by .xs files */
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); HV *plperl_spi_exec(char *, int);
void plperl_return_next(SV *); void plperl_return_next(SV *);
SV *plperl_spi_query(char *); SV *plperl_spi_query(char *);
......
src/pl/plperl/spi_internal.c deleted 100644 → 0
View file @ 5b13d1ff
/*
* $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;
}
src/pl/plperl/sql/plperl_util.sql 0 → 100644
View file @ 05672e50
-- 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();
src/pl/plperl/text2macro.pl
View file @ 05672e50
# $PostgreSQL: pgsql/src/pl/plperl/text2macro.pl,v 1.2 2010/01/20 01:08:21 adunstan Exp $
=head1 NAME =head1 NAME
text2macro.pl - convert text files into C string-literal macro definitions text2macro.pl - convert text files into C string-literal macro definitions
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment