Prepared queries for PLPerl, plus fixing a small plperl memory leak. Patch

doc/src/sgml/plperl.sgml

@@ -1,5 +1,5 @@
 <!--
-$PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.50 2006/03/01 06:30:32 neilc Exp $
+$PostgreSQL: pgsql/doc/src/sgml/plperl.sgml,v 2.51 2006/03/05 16:40:51 adunstan Exp $
 -->
 
  <chapter id="plperl">
@@ -296,7 +296,7 @@ BEGIN { strict->import(); }
   </para>
 
   <para>
-   PL/Perl provides three additional Perl commands:
+   PL/Perl provides additional Perl commands:
 
    <variablelist>
     <varlistentry>
@@ -306,9 +306,13 @@ BEGIN { strict->import(); }
      </indexterm>
 
      <term><literal><function>spi_exec_query</>(<replaceable>query</replaceable> [, <replaceable>max-rows</replaceable>])</literal></term>
-     <term><literal><function>spi_exec_query</>(<replaceable>command</replaceable>)</literal></term>
      <term><literal><function>spi_query</>(<replaceable>command</replaceable>)</literal></term>
-     <term><literal><function>spi_fetchrow</>(<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>
 
      <listitem>
       <para>
@@ -419,6 +423,66 @@ $$ LANGUAGE plperlu;
 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 must be freed with 
+    <literal>spi_freeplan</literal>:
+    </para>
+
+    <para>
+    <programlisting>
+CREATE OR REPLACE FUNCTION init() RETURNS INTEGER AS $$
+	$_SHARED{my_plan} = spi_prepare( 'SELECT (now() + $1)::date AS now', 'INTERVAL');
+$$ LANGUAGE plperl;
+
+CREATE OR REPLACE FUNCTION add_time( INTERVAL ) RETURNS TEXT AS $$
+	return spi_exec_prepared( 
+		$_SHARED{my_plan},
+		$_[0],
+	)->{rows}->[0]->{now};
+$$ LANGUAGE plperl;
+
+CREATE OR REPLACE FUNCTION done() RETURNS INTEGER AS $$
+	spi_freeplan( $_SHARED{my_plan});
+	undef $_SHARED{my_plan};
+$$ LANGUAGE plperl;
+
+SELECT init();
+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>
+    </para>
+
+    <para>
+    Note that the parameter subscript in <literal>spi_prepare</literal> is defined via
+    $1, $2, $3, etc, so avoid declaring query strings in double quotes that might easily
+    lead to hard-to-catch bugs.
+    </para>
+
+    <para>
+    <literal>spi_cursor_close</literal> can be used to abort sequence of
+    <literal>spi_fetchrow</literal> calls. Normally, the call to
+    <literal>spi_fetchrow</literal> that returns <literal>undef</literal> is
+    the signal that there are no more rows to read. Also
+    that call automatically frees the cursor associated with the query. If it is desired not
+    to read all retuned rows, <literal>spi_cursor_close</literal> must be
+    called to avoid memory leaks.  
+    </para>
+
 
      </listitem>
     </varlistentry>

src/pl/plperl/SPI.xs

@@ -111,7 +111,8 @@ spi_spi_exec_query(query, ...)
 		int limit = 0;
 	CODE:
 		if (items > 2)
-			croak("Usage: spi_exec_query(query, limit) or spi_exec_query(query)");
+			croak("Usage: spi_exec_query(query, limit) "
+				  "or spi_exec_query(query)");
 		if (items == 2)
 			limit = SvIV(ST(1));
 		ret_hash = plperl_spi_exec(query, limit);
@@ -141,5 +142,84 @@ spi_spi_fetchrow(cursor)
 	OUTPUT:
 		RETVAL
 
+SV*
+spi_spi_prepare(query, ...)
+	char* query;
+	CODE:
+		int i;
+		SV** argv;
+		if (items < 1) 
+			Perl_croak(aTHX_ "Usage: spi_prepare(query, ...)");
+		argv = ( SV**) palloc(( items - 1) * sizeof(SV*));
+		if ( argv == NULL) 
+			Perl_croak(aTHX_ "spi_prepare: not enough memory");
+		for ( i = 1; i < items; i++) 
+			argv[i - 1] = ST(i);
+		RETVAL = plperl_spi_prepare(query, items - 1, argv);
+		pfree( argv);
+	OUTPUT:
+		RETVAL
+
+SV*
+spi_spi_exec_prepared(query, ...)
+	char * query;
+	PREINIT:
+		HV *ret_hash;
+	CODE:
+		HV *attr = NULL;
+		int i, offset = 1, argc;
+		SV ** argv;
+		if ( items < 1) 
+			Perl_croak(aTHX_ "Usage: spi_exec_prepared(query, [\\%%attr,] " 
+					   "[\\@bind_values])");
+		if ( items > 1 && SvROK( ST( 1)) && SvTYPE( SvRV( ST( 1))) == SVt_PVHV)
+		{ 
+			attr = ( HV*) SvRV(ST(1));
+			offset++;
+		}
+		argc = items - offset;
+		argv = ( SV**) palloc( argc * sizeof(SV*));
+		if ( argv == NULL) 
+			Perl_croak(aTHX_ "spi_exec_prepared: not enough memory");
+		for ( i = 0; offset < items; offset++, i++) 
+			argv[i] = ST(offset);
+		ret_hash = plperl_spi_exec_prepared(query, attr, argc, argv);
+		RETVAL = newRV_noinc((SV*)ret_hash);
+		pfree( argv);
+	OUTPUT:
+		RETVAL
+
+SV*
+spi_spi_query_prepared(query, ...)
+	char * query;
+	CODE:
+		int i;
+		SV ** argv;
+		if ( items < 1) 
+			Perl_croak(aTHX_ "Usage: spi_query_prepared(query, "
+					   "[\\@bind_values])");
+		argv = ( SV**) palloc(( items - 1) * sizeof(SV*));
+		if ( argv == NULL) 
+			Perl_croak(aTHX_ "spi_query_prepared: not enough memory");
+		for ( i = 1; i < items; i++) 
+			argv[i - 1] = ST(i);
+		RETVAL = plperl_spi_query_prepared(query, items - 1, argv);
+		pfree( argv);
+	OUTPUT:
+		RETVAL
+
+void
+spi_spi_freeplan(query)
+	char *query;
+	CODE:
+		plperl_spi_freeplan(query);
+
+void
+spi_spi_cursor_close(cursor)
+	char *cursor;
+	CODE:
+		plperl_spi_cursor_close(cursor);
+
+
 BOOT:
     items = 0;  /* avoid 'unused variable' warning */

src/pl/plperl/expected/plperl.out

@@ -367,6 +367,20 @@ SELECT * from perl_spi_func();
              2
 (2 rows)
 
+--
+-- Test spi_fetchrow abort
+--
+CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
+my $x = spi_query("select 1 as a union select 2 as a");
+spi_cursor_close( $x);
+return 0;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_func2();
+ perl_spi_func2 
+----------------
+              0
+(1 row)
+
 ---
 --- Test recursion via SPI
 ---
@@ -420,3 +434,37 @@ SELECT array_of_text();
  {{"a\"b",NULL,"c,d"},{"e\\f",NULL,g}}
 (1 row)
 
+--
+-- Test spi_prepare/spi_exec_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$
+   my $x = spi_prepare('select $1 AS a', 'INT4');
+   my $q = spi_exec_prepared( $x, $_[0] + 1);
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared(42);
+ perl_spi_prepared 
+-------------------
+                43
+(1 row)
+
+--
+-- Test spi_prepare/spi_query_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$
+  my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4');
+  my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]);
+  while (defined (my $y = spi_fetchrow($q))) {
+      return_next $y->{a};
+  }
+  spi_freeplan($x);
+  return;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared_set(1,2);
+ perl_spi_prepared_set 
+-----------------------
+                     2
+                     4
+(2 rows)
+

src/pl/plperl/plperl.c

@@ -33,7 +33,7 @@
  *	  ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.103 2006/02/28 23:38:13 neilc Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.104 2006/03/05 16:40:51 adunstan Exp $
  *
  **********************************************************************/
 
@@ -56,6 +56,7 @@
 #include "utils/typcache.h"
 #include "miscadmin.h"
 #include "mb/pg_wchar.h"
+#include "parser/parse_type.h"
 
 /* define this before the perl headers get a chance to mangle DLLIMPORT */
 extern DLLIMPORT bool check_function_bodies;
@@ -99,6 +100,18 @@ typedef struct plperl_call_data
 	MemoryContext	  tmp_cxt;
 } plperl_call_data;
 
+/**********************************************************************
+ * The information we cache about prepared and saved plans
+ **********************************************************************/
+typedef struct plperl_query_desc
+{
+	char		qname[sizeof(long) * 2 + 1];
+	void	   *plan;
+	int			nargs;
+	Oid		   *argtypes;
+	FmgrInfo   *arginfuncs;
+	Oid		   *argtypioparams;
+} plperl_query_desc;
 
 /**********************************************************************
  * Global data
@@ -107,6 +120,7 @@ static bool plperl_firstcall = true;
 static bool plperl_safe_init_done = false;
 static PerlInterpreter *plperl_interp = NULL;
 static HV  *plperl_proc_hash = NULL;
+static HV  *plperl_query_hash = NULL;
 
 static bool plperl_use_strict = false;
 
@@ -233,7 +247,8 @@ plperl_init_all(void)
 	"$PLContainer->permit_only(':default');" \
 	"$PLContainer->permit(qw[:base_math !:base_io sort time]);" \
 	"$PLContainer->share(qw[&elog &spi_exec_query &return_next " \
-	"&spi_query &spi_fetchrow " \
+	"&spi_query &spi_fetchrow &spi_cursor_close " \
+	"&spi_prepare &spi_exec_prepared &spi_query_prepared &spi_freeplan " \
 	"&_plperl_to_pg_array " \
 	"&DEBUG &LOG &INFO &NOTICE &WARNING &ERROR %_SHARED ]);" \
 	"sub ::mksafefunc {" \
@@ -312,6 +327,7 @@ plperl_init_interp(void)
 	perl_run(plperl_interp);
 
 	plperl_proc_hash = newHV();
+	plperl_query_hash = newHV();
 
 #ifdef WIN32
 
@@ -1302,7 +1318,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 	{
 		bool		uptodate;
 
-		prodesc = (plperl_proc_desc *) SvIV(*svp);
+		prodesc = INT2PTR( plperl_proc_desc *, SvUV(*svp));
 
 		/************************************************************
 		 * If it's present, must check whether it's still up to date.
@@ -1500,7 +1516,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 		}
 
 		hv_store(plperl_proc_hash, internal_proname, proname_len,
-				 newSViv((IV) prodesc), 0);
+				 newSVuv( PTR2UV( prodesc)), 0);
 	}
 
 	ReleaseSysCache(procTup);
@@ -1810,16 +1826,20 @@ plperl_spi_query(char *query)
 	PG_TRY();
 	{
 		void	   *plan;
-		Portal		portal = NULL;
+		Portal		portal;
 
 		/* Create a cursor for the query */
 		plan = SPI_prepare(query, 0, NULL);
-		if (plan)
-			portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
-		if (portal)
-			cursor = newSVpv(portal->name, 0);
-		else
-			cursor = newSV(0);
+		if ( plan == NULL)
+			elog(ERROR, "SPI_prepare() failed:%s",
+				SPI_result_code_string(SPI_result));
+
+		portal = SPI_cursor_open(NULL, plan, NULL, NULL, false);
+		SPI_freeplan( plan);
+		if ( portal == NULL) 
+			elog(ERROR, "SPI_cursor_open() failed:%s",
+				SPI_result_code_string(SPI_result));
+		cursor = newSVpv(portal->name, 0);
 
 		/* Commit the inner transaction, return to outer xact context */
 		ReleaseCurrentSubTransaction();
@@ -1886,14 +1906,16 @@ plperl_spi_fetchrow(char *cursor)
 		Portal		p = SPI_cursor_find(cursor);
 
 		if (!p)
-			row = newSV(0);
+		{
+			row = &PL_sv_undef;
+		}
 		else
 		{
 			SPI_cursor_fetch(p, true, 1);
 			if (SPI_processed == 0)
 			{
 				SPI_cursor_close(p);
-				row = newSV(0);
+				row = &PL_sv_undef;
 			}
 			else
 			{
@@ -1945,3 +1967,451 @@ plperl_spi_fetchrow(char *cursor)
 
 	return row;
 }
+
+void
+plperl_spi_cursor_close(char *cursor)
+{
+	Portal p = SPI_cursor_find(cursor);
+	if (p)
+		SPI_cursor_close(p);
+}
+
+SV *
+plperl_spi_prepare(char* query, int argc, SV ** argv)
+{
+	plperl_query_desc *qdesc;
+	void	   *plan;
+	int			i;
+	HeapTuple	typeTup;
+
+	MemoryContext oldcontext = CurrentMemoryContext;
+	ResourceOwner oldowner = CurrentResourceOwner;
+
+	BeginInternalSubTransaction(NULL);
+	MemoryContextSwitchTo(oldcontext);
+
+	/************************************************************
+	 * Allocate the new querydesc structure
+	 ************************************************************/
+	qdesc = (plperl_query_desc *) malloc(sizeof(plperl_query_desc));
+	MemSet(qdesc, 0, sizeof(plperl_query_desc));
+	snprintf(qdesc-> qname, sizeof(qdesc-> qname), "%lx", (long) qdesc);
+	qdesc-> nargs = argc;
+	qdesc-> argtypes = (Oid *) malloc(argc * sizeof(Oid));
+	qdesc-> arginfuncs = (FmgrInfo *) malloc(argc * sizeof(FmgrInfo));
+	qdesc-> argtypioparams = (Oid *) malloc(argc * sizeof(Oid));
+
+	PG_TRY();
+	{
+		/************************************************************
+		 * Lookup the argument types by name in the system cache
+		 * and remember the required information for input conversion
+		 ************************************************************/
+		for (i = 0; i < argc; i++)
+		{
+			char	   *argcopy;
+			List	   *names = NIL;
+			ListCell   *l;
+			TypeName   *typename;
+
+			/************************************************************
+			 * Use SplitIdentifierString() on a copy of the type name,
+			 * turn the resulting pointer list into a TypeName node
+			 * and call typenameType() to get the pg_type tuple.
+			 ************************************************************/
+			argcopy = pstrdup(SvPV(argv[i],PL_na));
+			SplitIdentifierString(argcopy, '.', &names);
+			typename = makeNode(TypeName);
+			foreach(l, names)
+				typename->names = lappend(typename->names, makeString(lfirst(l)));
+
+			typeTup = typenameType(typename);
+			qdesc->argtypes[i] = HeapTupleGetOid(typeTup);
+			perm_fmgr_info(((Form_pg_type) GETSTRUCT(typeTup))->typinput,
+						   &(qdesc->arginfuncs[i]));
+			qdesc->argtypioparams[i] = getTypeIOParam(typeTup);
+			ReleaseSysCache(typeTup);
+
+			list_free(typename->names);
+			pfree(typename);
+			list_free(names);
+			pfree(argcopy);
+		}
+
+		/************************************************************
+		 * Prepare the plan and check for errors
+		 ************************************************************/
+		plan = SPI_prepare(query, argc, qdesc->argtypes);
+
+		if (plan == NULL)
+			elog(ERROR, "SPI_prepare() failed:%s",
+				SPI_result_code_string(SPI_result));
+
+		/************************************************************
+		 * Save the plan into permanent memory (right now it's in the
+		 * SPI procCxt, which will go away at function end).
+		 ************************************************************/
+		qdesc->plan = SPI_saveplan(plan);
+		if (qdesc->plan == NULL)
+			elog(ERROR, "SPI_saveplan() failed: %s", 
+				SPI_result_code_string(SPI_result));
+
+		/* Release the procCxt copy to avoid within-function memory leak */
+		SPI_freeplan(plan);
+
+		/* Commit the inner transaction, return to outer xact context */
+		ReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+		/*
+		 * AtEOSubXact_SPI() should not have popped any SPI context,
+		 * but just in case it did, make sure we remain connected.
+		 */
+		SPI_restore_connection();
+	}
+	PG_CATCH();
+	{
+		ErrorData  *edata;
+		
+		free(qdesc-> argtypes);
+		free(qdesc-> arginfuncs);
+		free(qdesc-> argtypioparams);
+		free(qdesc);
+
+		/* Save error info */
+		MemoryContextSwitchTo(oldcontext);
+		edata = CopyErrorData();
+		FlushErrorState();
+
+		/* Abort the inner transaction */
+		RollbackAndReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+
+		/*
+		 * If AtEOSubXact_SPI() popped any SPI context of the subxact,
+		 * it will have left us in a disconnected state.  We need this
+		 * hack to return to connected state.
+		 */
+		SPI_restore_connection();
+
+		/* Punt the error to Perl */
+		croak("%s", edata->message);
+
+		/* Can't get here, but keep compiler quiet */
+		return NULL;
+	}
+	PG_END_TRY();
+
+	/************************************************************
+	 * Insert a hashtable entry for the plan and return
+	 * the key to the caller.
+	 ************************************************************/
+	hv_store( plperl_query_hash, qdesc->qname, strlen(qdesc->qname), newSVuv( PTR2UV( qdesc)), 0);
+
+	return newSVpv( qdesc->qname, strlen(qdesc->qname));
+}	
+
+HV *
+plperl_spi_exec_prepared(char* query, HV * attr, int argc, SV ** argv)
+{
+	HV		   *ret_hv;
+	SV **sv;
+	int i, limit, spi_rv;
+	char * nulls;
+	Datum	   *argvalues;
+	plperl_query_desc *qdesc;
+
+	/*
+	 * Execute the query inside a sub-transaction, so we can cope with
+	 * errors sanely
+	 */
+	MemoryContext oldcontext = CurrentMemoryContext;
+	ResourceOwner oldowner = CurrentResourceOwner;
+
+	BeginInternalSubTransaction(NULL);
+	/* Want to run inside function's memory context */
+	MemoryContextSwitchTo(oldcontext);
+
+	PG_TRY();
+	{
+		/************************************************************
+		 * Fetch the saved plan descriptor, see if it's o.k.
+		 ************************************************************/
+		sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+		if ( sv == NULL) 
+			elog(ERROR, "spi_exec_prepared: Invalid prepared query passed");
+		if ( *sv == NULL || !SvOK( *sv))
+			elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value corrupted");
+
+		qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
+		if ( qdesc == NULL)
+			elog(ERROR, "spi_exec_prepared: panic - plperl_query_hash value vanished");
+
+		if ( qdesc-> nargs != argc) 
+			elog(ERROR, "spi_exec_prepared: expected %d argument(s), %d passed", 
+				qdesc-> nargs, argc);
+		
+		/************************************************************
+		 * Parse eventual attributes
+		 ************************************************************/
+		limit = 0;
+		if ( attr != NULL) 
+		{
+			sv = hv_fetch( attr, "limit", 5, 0);
+			if ( *sv && SvIOK( *sv))
+				limit = SvIV( *sv);
+		}
+		/************************************************************
+		 * Set up arguments
+		 ************************************************************/
+		if ( argc > 0) 
+		{
+			nulls = (char *)palloc( argc);
+			argvalues = (Datum *) palloc(argc * sizeof(Datum));
+			if ( nulls == NULL || argvalues == NULL) 
+				elog(ERROR, "spi_exec_prepared: not enough memory");
+		} 
+		else 
+		{
+			nulls = NULL;
+			argvalues = NULL;
+		}
+
+		for ( i = 0; i < argc; i++) 
+		{
+			if ( SvTYPE( argv[i]) != SVt_NULL) 
+			{
+				argvalues[i] =
+					FunctionCall3( &qdesc->arginfuncs[i],
+						  CStringGetDatum( SvPV( argv[i], PL_na)),
+						  ObjectIdGetDatum( qdesc->argtypioparams[i]),
+						  Int32GetDatum(-1)
+					);
+				nulls[i] = ' ';
+			} 
+			else 
+			{
+				argvalues[i] = (Datum) 0;
+				nulls[i] = 'n';
+			}
+		}
+
+		/************************************************************
+		 * go
+		 ************************************************************/
+		spi_rv = SPI_execute_plan(qdesc-> plan, argvalues, nulls, 
+							 current_call_data->prodesc->fn_readonly, limit);
+		ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
+												 spi_rv);
+		if ( argc > 0) 
+		{
+			pfree( argvalues);
+			pfree( nulls);
+		}
+
+		/* Commit the inner transaction, return to outer xact context */
+		ReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+		/*
+		 * AtEOSubXact_SPI() should not have popped any SPI context,
+		 * but just in case it did, make sure we remain connected.
+		 */
+		SPI_restore_connection();
+	}
+	PG_CATCH();
+	{
+		ErrorData  *edata;
+
+		/* Save error info */
+		MemoryContextSwitchTo(oldcontext);
+		edata = CopyErrorData();
+		FlushErrorState();
+
+		/* Abort the inner transaction */
+		RollbackAndReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+
+		/*
+		 * If AtEOSubXact_SPI() popped any SPI context of the subxact,
+		 * it will have left us in a disconnected state.  We need this
+		 * hack to return to connected state.
+		 */
+		SPI_restore_connection();
+
+		/* Punt the error to Perl */
+		croak("%s", edata->message);
+
+		/* Can't get here, but keep compiler quiet */
+		return NULL;
+	}
+	PG_END_TRY();
+
+	return ret_hv;
+}
+
+SV *
+plperl_spi_query_prepared(char* query, int argc, SV ** argv)
+{
+	SV **sv;
+	int i;
+	char * nulls;
+	Datum	   *argvalues;
+	plperl_query_desc *qdesc;
+	SV *cursor;
+	Portal portal = NULL;
+
+	/*
+	 * Execute the query inside a sub-transaction, so we can cope with
+	 * errors sanely
+	 */
+	MemoryContext oldcontext = CurrentMemoryContext;
+	ResourceOwner oldowner = CurrentResourceOwner;
+
+	BeginInternalSubTransaction(NULL);
+	/* Want to run inside function's memory context */
+	MemoryContextSwitchTo(oldcontext);
+
+	PG_TRY();
+	{
+		/************************************************************
+		 * Fetch the saved plan descriptor, see if it's o.k.
+		 ************************************************************/
+		sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+		if ( sv == NULL) 
+			elog(ERROR, "spi_query_prepared: Invalid prepared query passed");
+		if ( *sv == NULL || !SvOK( *sv))
+			elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value corrupted");
+
+		qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
+		if ( qdesc == NULL)
+			elog(ERROR, "spi_query_prepared: panic - plperl_query_hash value vanished");
+
+		if ( qdesc-> nargs != argc) 
+			elog(ERROR, "spi_query_prepared: expected %d argument(s), %d passed", 
+				qdesc-> nargs, argc);
+		
+		/************************************************************
+		 * Set up arguments
+		 ************************************************************/
+		if ( argc > 0) 
+		{
+			nulls = (char *)palloc( argc);
+			argvalues = (Datum *) palloc(argc * sizeof(Datum));
+			if ( nulls == NULL || argvalues == NULL) 
+				elog(ERROR, "spi_query_prepared: not enough memory");
+		} 
+		else 
+		{
+			nulls = NULL;
+			argvalues = NULL;
+		}
+
+		for ( i = 0; i < argc; i++) 
+		{
+			if ( SvTYPE( argv[i]) != SVt_NULL) 
+			{
+				argvalues[i] =
+					FunctionCall3( &qdesc->arginfuncs[i],
+						  CStringGetDatum( SvPV( argv[i], PL_na)),
+						  ObjectIdGetDatum( qdesc->argtypioparams[i]),
+						  Int32GetDatum(-1)
+					);
+				nulls[i] = ' ';
+			} 
+			else 
+			{
+				argvalues[i] = (Datum) 0;
+				nulls[i] = 'n';
+			}
+		}
+
+		/************************************************************
+		 * go
+		 ************************************************************/
+		portal = SPI_cursor_open(NULL, qdesc-> plan, argvalues, nulls, 
+							current_call_data->prodesc->fn_readonly);
+		if ( argc > 0) 
+		{
+			pfree( argvalues);
+			pfree( nulls);
+		}
+		if ( portal == NULL) 
+			elog(ERROR, "SPI_cursor_open() failed:%s",
+				SPI_result_code_string(SPI_result));
+
+		cursor = newSVpv(portal->name, 0);
+
+		/* Commit the inner transaction, return to outer xact context */
+		ReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+		/*
+		 * AtEOSubXact_SPI() should not have popped any SPI context,
+		 * but just in case it did, make sure we remain connected.
+		 */
+		SPI_restore_connection();
+	}
+	PG_CATCH();
+	{
+		ErrorData  *edata;
+
+		/* Save error info */
+		MemoryContextSwitchTo(oldcontext);
+		edata = CopyErrorData();
+		FlushErrorState();
+
+		/* Abort the inner transaction */
+		RollbackAndReleaseCurrentSubTransaction();
+		MemoryContextSwitchTo(oldcontext);
+		CurrentResourceOwner = oldowner;
+
+		/*
+		 * If AtEOSubXact_SPI() popped any SPI context of the subxact,
+		 * it will have left us in a disconnected state.  We need this
+		 * hack to return to connected state.
+		 */
+		SPI_restore_connection();
+
+		/* Punt the error to Perl */
+		croak("%s", edata->message);
+
+		/* Can't get here, but keep compiler quiet */
+		return NULL;
+	}
+	PG_END_TRY();
+
+	return cursor;
+}
+
+void
+plperl_spi_freeplan(char *query)
+{
+	SV ** sv;
+	void * plan;
+	plperl_query_desc *qdesc;
+
+	sv = hv_fetch(plperl_query_hash, query, strlen(query), 0);
+	if ( sv == NULL) 
+		elog(ERROR, "spi_exec_freeplan: Invalid prepared query passed");
+	if ( *sv == NULL || !SvOK( *sv))
+		elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value corrupted");
+
+	qdesc = INT2PTR( plperl_query_desc *, SvUV(*sv));
+	if ( qdesc == NULL)
+		elog(ERROR, "spi_exec_freeplan: panic - plperl_query_hash value vanished");
+
+	/*
+	*	free all memory before SPI_freeplan, so if it dies, nothing will be left over
+	*/
+	hv_delete(plperl_query_hash, query, strlen(query), G_DISCARD);
+	plan = qdesc-> plan;
+	free(qdesc-> argtypes);
+	free(qdesc-> arginfuncs);
+	free(qdesc-> argtypioparams);
+	free(qdesc);
+
+	SPI_freeplan( plan);
+}

src/pl/plperl/plperl.h

@@ -8,7 +8,7 @@
  * Portions Copyright (c) 1996-2006, PostgreSQL Global Development Group
  * Portions Copyright (c) 1995, Regents of the University of California
  *
- * $PostgreSQL: pgsql/src/pl/plperl/plperl.h,v 1.3 2006/03/05 15:59:10 momjian Exp $
+ * $PostgreSQL: pgsql/src/pl/plperl/plperl.h,v 1.4 2006/03/05 16:40:51 adunstan Exp $
  */
 
 #ifndef PL_PERL_H
@@ -51,6 +51,12 @@ HV		   *plperl_spi_exec(char *, int);
 void		plperl_return_next(SV *);
 SV		   *plperl_spi_query(char *);
 SV		   *plperl_spi_fetchrow(char *);
+SV *plperl_spi_prepare(char *, int, SV **);
+HV *plperl_spi_exec_prepared(char *, HV *, int, SV **);
+SV *plperl_spi_query_prepared(char *, int, SV **);
+void plperl_spi_freeplan(char *);
+void plperl_spi_cursor_close(char *);
+
 
 
 #endif /* PL_PERL_H */

src/pl/plperl/sql/plperl.sql

@@ -261,6 +261,16 @@ return;
 $$ LANGUAGE plperl;
 SELECT * from perl_spi_func();
 
+--
+-- Test spi_fetchrow abort
+--
+CREATE OR REPLACE FUNCTION perl_spi_func2() RETURNS INTEGER AS $$
+my $x = spi_query("select 1 as a union select 2 as a");
+spi_cursor_close( $x);
+return 0;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_func2();
+
 
 ---
 --- Test recursion via SPI
@@ -300,4 +310,30 @@ LANGUAGE plperl as $$
     return [['a"b',undef,'c,d'],['e\\f',undef,'g']]; 
 $$;
 
-SELECT array_of_text(); 
+SELECT array_of_text();
+
+--
+-- Test spi_prepare/spi_exec_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared(INTEGER) RETURNS INTEGER AS $$
+   my $x = spi_prepare('select $1 AS a', 'INT4');
+   my $q = spi_exec_prepared( $x, $_[0] + 1);
+   spi_freeplan($x);
+return $q->{rows}->[0]->{a};
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared(42);
+
+--
+-- Test spi_prepare/spi_query_prepared/spi_freeplan
+--
+CREATE OR REPLACE FUNCTION perl_spi_prepared_set(INTEGER, INTEGER) RETURNS SETOF INTEGER AS $$
+  my $x = spi_prepare('SELECT $1 AS a union select $2 as a', 'INT4', 'INT4');
+  my $q = spi_query_prepared( $x, 1+$_[0], 2+$_[1]);
+  while (defined (my $y = spi_fetchrow($q))) {
+      return_next $y->{a};
+  }
+  spi_freeplan($x);
+  return;
+$$ LANGUAGE plperl;
+SELECT * from perl_spi_prepared_set(1,2);
+