diff --git a/doc/src/sgml/plperl.sgml b/doc/src/sgml/plperl.sgml
index 3e7d3b2aa3b783cdc03fc49069eb5abb02e7534e..9211693d3d912d31b270495bbef89ea2f9f8dd4f 100644
--- a/doc/src/sgml/plperl.sgml
+++ b/doc/src/sgml/plperl.sgml
@@ -1,4 +1,4 @@
-<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.70 2009/08/15 00:33:12 petere Exp $ -->
+<!-- $PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.71 2009/11/29 03:02:27 tgl Exp $ -->
<chapter id="plperl">
<title>PL/Perl - Perl Procedural Language</title>
@@ -59,11 +59,26 @@ CREATE FUNCTION <replaceable>funcname</replaceable> (<replaceable>argument-types
# PL/Perl function body
$$ LANGUAGE plperl;
</programlisting>
+
The body of the function is ordinary Perl code. In fact, the PL/Perl
- glue code wraps it inside a Perl subroutine. A PL/Perl function must
- always return a scalar value. You can return more complex structures
- (arrays, records, and sets) by returning a reference, as discussed below.
- Never return a list.
+ glue code wraps it inside a Perl subroutine. A PL/Perl function is
+ called in a scalar context, so it can't return a list. You can return
+ non-scalar values (arrays, records, and sets) by returning a reference,
+ as discussed below.
+ </para>
+
+ <para>
+ PL/Perl also supports anonymous code blocks called with the
+ <xref linkend="sql-do" endterm="sql-do-title"> statement:
+
+<programlisting>
+DO $$
+ # PL/Perl code
+$$ LANGUAGE plperl;
+</programlisting>
+
+ An anonymous code block receives no arguments, and whatever value it
+ might return is discarded. Otherwise it behaves just like a function.
</para>
<note>
@@ -669,6 +684,13 @@ $$ LANGUAGE plperl;
<literal>plperlu</>, execution would succeed.
</para>
+ <para>
+ In the same way, anonymous code blocks written in Perl can use
+ restricted operations if the language is specified as
+ <literal>plperlu</> rather than <literal>plperl</>, but the caller
+ must be a superuser.
+ </para>
+
<note>
<para>
For security reasons, to stop a leak of privileged operations from
diff --git a/src/include/catalog/catversion.h b/src/include/catalog/catversion.h
index 61b7ccd822bc69051acf46f1da9a52b22ea96d61..d7225ae0c4f6800a07ed2b6e7a87120b2d42d32f 100644
--- a/src/include/catalog/catversion.h
+++ b/src/include/catalog/catversion.h
@@ -37,7 +37,7 @@
* Portions Copyright (c) 1996-2009, PostgreSQL Global Development Group
* Portions Copyright (c) 1994, Regents of the University of California
*
- * $PostgreSQL: pgsql/src/include/catalog/catversion.h,v 1.552 2009/11/28 23:38:07 tgl Exp $
+ * $PostgreSQL: pgsql/src/include/catalog/catversion.h,v 1.553 2009/11/29 03:02:27 tgl Exp $
*
*-------------------------------------------------------------------------
*/
@@ -53,6 +53,6 @@
*/
/* yyyymmddN */
-#define CATALOG_VERSION_NO 200911281
+#define CATALOG_VERSION_NO 200911282
#endif
diff --git a/src/include/catalog/pg_pltemplate.h b/src/include/catalog/pg_pltemplate.h
index 2065a5332bb218ffbd0e8a6deebd51fc43f2912c..06f3e98ddea5b5b96a0275783b171e045b748ec1 100644
--- a/src/include/catalog/pg_pltemplate.h
+++ b/src/include/catalog/pg_pltemplate.h
@@ -8,7 +8,7 @@
* Portions Copyright (c) 1996-2009, PostgreSQL Global Development Group
* Portions Copyright (c) 1994, Regents of the University of California
*
- * $PostgreSQL: pgsql/src/include/catalog/pg_pltemplate.h,v 1.8 2009/09/22 23:43:41 tgl Exp $
+ * $PostgreSQL: pgsql/src/include/catalog/pg_pltemplate.h,v 1.9 2009/11/29 03:02:27 tgl Exp $
*
* NOTES
* the genbki.sh script reads this file and generates .bki
@@ -70,8 +70,8 @@ typedef FormData_pg_pltemplate *Form_pg_pltemplate;
DATA(insert ( "plpgsql" t t "plpgsql_call_handler" "plpgsql_inline_handler" "plpgsql_validator" "$libdir/plpgsql" _null_ ));
DATA(insert ( "pltcl" t t "pltcl_call_handler" _null_ _null_ "$libdir/pltcl" _null_ ));
DATA(insert ( "pltclu" f f "pltclu_call_handler" _null_ _null_ "$libdir/pltcl" _null_ ));
-DATA(insert ( "plperl" t t "plperl_call_handler" _null_ "plperl_validator" "$libdir/plperl" _null_ ));
-DATA(insert ( "plperlu" f f "plperl_call_handler" _null_ "plperl_validator" "$libdir/plperl" _null_ ));
+DATA(insert ( "plperl" t t "plperl_call_handler" "plperl_inline_handler" "plperl_validator" "$libdir/plperl" _null_ ));
+DATA(insert ( "plperlu" f f "plperl_call_handler" "plperl_inline_handler" "plperl_validator" "$libdir/plperl" _null_ ));
DATA(insert ( "plpythonu" f f "plpython_call_handler" _null_ _null_ "$libdir/plpython" _null_ ));
#endif /* PG_PLTEMPLATE_H */
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index c8a8fdb877958ed8cf6a7bed3c23896e8d78a8d4..b94273911de34344d571c23493cae07ac08aa005 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -555,3 +555,14 @@ $$ LANGUAGE plperl;
SELECT perl_spi_prepared_bad(4.35) as "double precision";
ERROR: type "does_not_exist" does not exist at line 2.
CONTEXT: PL/Perl function "perl_spi_prepared_bad"
+-- simple test of a DO block
+DO $$
+ $a = 'This is a test';
+ elog(NOTICE, $a);
+$$ LANGUAGE plperl;
+NOTICE: This is a test
+CONTEXT: PL/Perl anonymous code block
+-- check that restricted operations are rejected in a plperl DO block
+DO $$ use Config; $$ LANGUAGE plperl;
+ERROR: 'require' trapped by operation mask at line 1.
+CONTEXT: PL/Perl anonymous code block
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 9ae4962b21d2ae5e90c8ded402018acf74c73a52..852b2b155b0b13b6118f81ff5e80e7c528d337ad 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.153 2009/10/31 18:11:59 tgl Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.154 2009/11/29 03:02:27 tgl Exp $
*
**********************************************************************/
@@ -144,6 +144,7 @@ static plperl_call_data *current_call_data = NULL;
* Forward declarations
**********************************************************************/
Datum plperl_call_handler(PG_FUNCTION_ARGS);
+Datum plperl_inline_handler(PG_FUNCTION_ARGS);
Datum plperl_validator(PG_FUNCTION_ARGS);
void _PG_init(void);
@@ -160,10 +161,11 @@ static HV *plperl_spi_execute_fetch_result(SPITupleTable *, int, int);
static SV *newSVstring(const char *str);
static SV **hv_store_string(HV *hv, const char *key, SV *val);
static SV **hv_fetch_string(HV *hv, const char *key);
-static SV *plperl_create_sub(char *proname, char *s, bool trusted);
+static SV *plperl_create_sub(const char *proname, const char *s, bool trusted);
static SV *plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo);
static void plperl_compile_callback(void *arg);
static void plperl_exec_callback(void *arg);
+static void plperl_inline_callback(void *arg);
/*
* This routine is a crock, and so is everyplace that calls it. The problem
@@ -862,9 +864,13 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
/*
- * This is the only externally-visible part of the plperl call interface.
- * The Postgres function and trigger managers call it to execute a
- * perl function.
+ * There are three externally visible pieces to plperl: plperl_call_handler,
+ * plperl_inline_handler, and plperl_validator.
+ */
+
+/*
+ * The call handler is called to run normal functions (including trigger
+ * functions) that are defined in pg_proc.
*/
PG_FUNCTION_INFO_V1(plperl_call_handler);
@@ -896,8 +902,102 @@ plperl_call_handler(PG_FUNCTION_ARGS)
}
/*
- * This is the other externally visible function - it is called when CREATE
- * FUNCTION is issued to validate the function being created/replaced.
+ * The inline handler runs anonymous code blocks (DO blocks).
+ */
+PG_FUNCTION_INFO_V1(plperl_inline_handler);
+
+Datum
+plperl_inline_handler(PG_FUNCTION_ARGS)
+{
+ InlineCodeBlock *codeblock = (InlineCodeBlock *) PG_GETARG_POINTER(0);
+ FunctionCallInfoData fake_fcinfo;
+ FmgrInfo flinfo;
+ plperl_proc_desc desc;
+ plperl_call_data *save_call_data = current_call_data;
+ bool oldcontext = trusted_context;
+ ErrorContextCallback pl_error_context;
+
+ /* Set up a callback for error reporting */
+ pl_error_context.callback = plperl_inline_callback;
+ pl_error_context.previous = error_context_stack;
+ pl_error_context.arg = (Datum) 0;
+ error_context_stack = &pl_error_context;
+
+ /*
+ * Set up a fake fcinfo and descriptor with just enough info to satisfy
+ * plperl_call_perl_func(). In particular note that this sets things up
+ * with no arguments passed, and a result type of VOID.
+ */
+ MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo));
+ MemSet(&flinfo, 0, sizeof(flinfo));
+ MemSet(&desc, 0, sizeof(desc));
+ fake_fcinfo.flinfo = &flinfo;
+ flinfo.fn_oid = InvalidOid;
+ flinfo.fn_mcxt = CurrentMemoryContext;
+
+ desc.proname = "inline_code_block";
+ desc.fn_readonly = false;
+
+ desc.lanpltrusted = codeblock->langIsTrusted;
+
+ desc.fn_retistuple = false;
+ desc.fn_retisset = false;
+ desc.fn_retisarray = false;
+ desc.result_oid = VOIDOID;
+ desc.nargs = 0;
+ desc.reference = NULL;
+
+ current_call_data = (plperl_call_data *) palloc0(sizeof(plperl_call_data));
+ current_call_data->fcinfo = &fake_fcinfo;
+ current_call_data->prodesc = &desc;
+
+ PG_TRY();
+ {
+ SV *perlret;
+
+ if (SPI_connect() != SPI_OK_CONNECT)
+ elog(ERROR, "could not connect to SPI manager");
+
+ check_interp(desc.lanpltrusted);
+
+ desc.reference = plperl_create_sub(desc.proname,
+ codeblock->source_text,
+ desc.lanpltrusted);
+
+ if (!desc.reference) /* can this happen? */
+ elog(ERROR, "could not create internal procedure for anonymous code block");
+
+ perlret = plperl_call_perl_func(&desc, &fake_fcinfo);
+
+ SvREFCNT_dec(perlret);
+
+ if (SPI_finish() != SPI_OK_FINISH)
+ elog(ERROR, "SPI_finish() failed");
+ }
+ PG_CATCH();
+ {
+ current_call_data = save_call_data;
+ restore_context(oldcontext);
+ if (desc.reference)
+ SvREFCNT_dec(desc.reference);
+ PG_RE_THROW();
+ }
+ PG_END_TRY();
+
+ current_call_data = save_call_data;
+ restore_context(oldcontext);
+ if (desc.reference)
+ SvREFCNT_dec(desc.reference);
+
+ error_context_stack = pl_error_context.previous;
+
+ PG_RETURN_VOID();
+}
+
+/*
+ * The validator is called during CREATE FUNCTION to validate the function
+ * being created/replaced. The precise behavior of the validator may be
+ * modified by the check_function_bodies GUC.
*/
PG_FUNCTION_INFO_V1(plperl_validator);
@@ -971,7 +1071,7 @@ plperl_validator(PG_FUNCTION_ARGS)
* supplied in s, and returns a reference to the closure.
*/
static SV *
-plperl_create_sub(char *proname, char *s, bool trusted)
+plperl_create_sub(const char *proname, const char *s, bool trusted)
{
dSP;
SV *subref;
@@ -1375,7 +1475,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
/* Restore the previous error callback */
error_context_stack = pl_error_context.previous;
-
+
if (array_ret == NULL)
SvREFCNT_dec(perlret);
@@ -2716,9 +2816,9 @@ hv_fetch_string(HV *hv, const char *key)
}
/*
- * Provide function name for PL/Perl execution errors
+ * Provide function name for PL/Perl execution errors
*/
-static void
+static void
plperl_exec_callback(void *arg)
{
char *procname = (char *) arg;
@@ -2727,7 +2827,7 @@ plperl_exec_callback(void *arg)
}
/*
- * Provide function name for PL/Perl compilation errors
+ * Provide function name for PL/Perl compilation errors
*/
static void
plperl_compile_callback(void *arg)
@@ -2736,3 +2836,12 @@ plperl_compile_callback(void *arg)
if (procname)
errcontext("compilation of PL/Perl function \"%s\"", procname);
}
+
+/*
+ * Provide error context for the inline handler
+ */
+static void
+plperl_inline_callback(void *arg)
+{
+ errcontext("PL/Perl anonymous code block");
+}
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index df17834952f2d406e3b9591607188d745c5e6333..f12e2f7251619a6c41357bc4a1ce459e79b2cfca 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -361,3 +361,11 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
$$ LANGUAGE plperl;
SELECT perl_spi_prepared_bad(4.35) as "double precision";
+-- simple test of a DO block
+DO $$
+ $a = 'This is a test';
+ elog(NOTICE, $a);
+$$ LANGUAGE plperl;
+
+-- check that restricted operations are rejected in a plperl DO block
+DO $$ use Config; $$ LANGUAGE plperl;