+ return newRV_noinc((SV *) hv);
+}
+
+
+HV *
+plperl_spi_exec(char *query, int limit)
+{
+ HV *ret_hv;
+
+ /*
+ * 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();
+ {
+ int spi_rv;
+
+ spi_rv = SPI_execute(query, current_call_data->prodesc->fn_readonly,
+ limit);
+ ret_hv = plperl_spi_execute_fetch_result(SPI_tuptable, SPI_processed,
+ spi_rv);
+
+ /* 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;
+}
+
+
+static HV *
+plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
+ int status)
+{
+ HV *result;
+
+ result = newHV();
+
+ hv_store(result, "status", strlen("status"),
+ newSVpv((char *) SPI_result_code_string(status), 0), 0);
+ hv_store(result, "processed", strlen("processed"),
+ newSViv(processed), 0);
+
+ if (status == SPI_OK_SELECT)
+ {
+ AV *rows;
+ SV *row;
+ int i;
+
+ rows = newAV();
+ for (i = 0; i < processed; i++)
+ {
+ row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);
+ av_push(rows, row);
+ }
+ hv_store(result, "rows", strlen("rows"),
+ newRV_noinc((SV *) rows), 0);
+ }
+
+ SPI_freetuptable(tuptable);
+
+ return result;
+}
+
+
+/*
+ * Note: plperl_return_next is called both in Postgres and Perl contexts.
+ * We report any errors in Postgres fashion (via ereport). If called in
+ * Perl context, it is SPI.xs's responsibility to catch the error and
+ * convert to a Perl error. We assume (perhaps without adequate justification)
+ * that we need not abort the current transaction if the Perl code traps the
+ * error.
+ */
+void
+plperl_return_next(SV *sv)
+{
+ plperl_proc_desc *prodesc;
+ FunctionCallInfo fcinfo;
+ ReturnSetInfo *rsi;
+ MemoryContext old_cxt;
+ HeapTuple tuple;
+
+ if (!sv)
+ return;
+
+ prodesc = current_call_data->prodesc;
+ fcinfo = current_call_data->fcinfo;
+ rsi = (ReturnSetInfo *) fcinfo->resultinfo;
+
+ if (!prodesc->fn_retisset)
+ ereport(ERROR,
+ (errcode(ERRCODE_SYNTAX_ERROR),
+ errmsg("cannot use return_next in a non-SETOF function")));
+
+ if (prodesc->fn_retistuple &&
+ !(SvOK(sv) && SvTYPE(sv) == SVt_RV && SvTYPE(SvRV(sv)) == SVt_PVHV))
+ ereport(ERROR,
+ (errcode(ERRCODE_DATATYPE_MISMATCH),
+ errmsg("setof-composite-returning Perl function "
+ "must call return_next with reference to hash")));
+
+ if (!current_call_data->ret_tdesc)
+ {
+ TupleDesc tupdesc;
+
+ Assert(!current_call_data->tuple_store);
+ Assert(!current_call_data->attinmeta);
+
+ /*
+ * This is the first call to return_next in the current
+ * PL/Perl function call, so memoize some lookups
+ */
+ if (prodesc->fn_retistuple)
+ (void) get_call_result_type(fcinfo, NULL, &tupdesc);
+ else
+ tupdesc = rsi->expectedDesc;
+
+ /*
+ * Make sure the tuple_store and ret_tdesc are sufficiently
+ * long-lived.
+ */
+ old_cxt = MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
+
+ current_call_data->ret_tdesc = CreateTupleDescCopy(tupdesc);
+ current_call_data->tuple_store =
+ tuplestore_begin_heap(true, false, work_mem);
+ if (prodesc->fn_retistuple)
+ {
+ current_call_data->attinmeta =
+ TupleDescGetAttInMetadata(current_call_data->ret_tdesc);
+ }
+
+ MemoryContextSwitchTo(old_cxt);
+ }
+
+ /*
+ * Producing the tuple we want to return requires making plenty of
+ * palloc() allocations that are not cleaned up. Since this
+ * function can be called many times before the current memory
+ * context is reset, we need to do those allocations in a
+ * temporary context.
+ */
+ if (!current_call_data->tmp_cxt)
+ {
+ current_call_data->tmp_cxt =
+ AllocSetContextCreate(rsi->econtext->ecxt_per_tuple_memory,
+ "PL/Perl return_next temporary cxt",
+ ALLOCSET_DEFAULT_MINSIZE,
+ ALLOCSET_DEFAULT_INITSIZE,
+ ALLOCSET_DEFAULT_MAXSIZE);
+ }
+
+ old_cxt = MemoryContextSwitchTo(current_call_data->tmp_cxt);
+
+ if (prodesc->fn_retistuple)
+ {
+ tuple = plperl_build_tuple_result((HV *) SvRV(sv),
+ current_call_data->attinmeta);
+ }
+ else
+ {
+ Datum ret = (Datum) 0;
+ bool isNull = true;
+
+ if (SvOK(sv) && SvTYPE(sv) != SVt_NULL)
+ {
+ char *val = SvPV(sv, PL_na);
+
+ ret = FunctionCall3(&prodesc->result_in_func,
+ PointerGetDatum(val),
+ ObjectIdGetDatum(prodesc->result_typioparam),
+ Int32GetDatum(-1));
+ isNull = false;
+ }
+
+ tuple = heap_form_tuple(current_call_data->ret_tdesc, &ret, &isNull);
+ }
+
+ /* Make sure to store the tuple in a long-lived memory context */
+ MemoryContextSwitchTo(rsi->econtext->ecxt_per_query_memory);
+ tuplestore_puttuple(current_call_data->tuple_store, tuple);
+ MemoryContextSwitchTo(old_cxt);
+
+ MemoryContextReset(current_call_data->tmp_cxt);
+}
+
+
+SV *
+plperl_spi_query(char *query)
+{
+ SV *cursor;
+
+ /*
+ * 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();
+ {
+ void *plan;
+ Portal portal = NULL;
+
+ /* 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);
+
+ /* 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;
+}
+
+
+SV *
+plperl_spi_fetchrow(char *cursor)
+{
+ SV *row;
+
+ /*
+ * Execute the FETCH 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();
+ {
+ Portal p = SPI_cursor_find(cursor);
+
+ if (!p)
+ row = newSV(0);
+ else
+ {
+ SPI_cursor_fetch(p, true, 1);
+ if (SPI_processed == 0)
+ {
+ SPI_cursor_close(p);
+ row = newSV(0);
+ }
+ else
+ {
+ row = plperl_hash_from_tuple(SPI_tuptable->vals[0],
+ SPI_tuptable->tupdesc);
+ }
+ SPI_freetuptable(SPI_tuptable);
+ }
+
+ /* 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 row;