Fix plperl's elog() function to convert elog(ERROR) into Perl croak(),

tglsfdc · tglsfdc · commit 193a97c2d32a · 2004-11-20T19:07:40.000Z
rather than longjmp'ing clear out of Perl and thereby leaving Perl in
a broken state.  Also some minor prettification of error messages.
Still need to do something with spi_exec_query() error handling.
diff --git a/src/pl/plperl/SPI.xs b/src/pl/plperl/SPI.xs
@@ -10,6 +10,40 @@
 #include "spi_internal.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();
+}
+
 
 MODULE = SPI PREFIX = spi_
 
@@ -21,8 +55,11 @@ spi_elog(level, message)
 	int level
 	char* message
 	CODE:
-	elog(level, message);
-
+		if (level > ERROR)		/* no PANIC allowed thanks */
+			level = ERROR;
+		if (level < DEBUG5)
+			level = DEBUG5;
+		do_spi_elog(level, message);
 
 int
 spi_DEBUG()
@@ -47,11 +84,13 @@ spi_spi_exec_query(query, ...)
 	char* query;
 	PREINIT:
 		HV *ret_hash;
-		int limit=0;
+		int limit = 0;
 	CODE:
-			if (items>2) Perl_croak(aTHX_ "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);
-		RETVAL = newRV_noinc((SV*)ret_hash);
+		if (items > 2)
+			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);
+		RETVAL = newRV_noinc((SV*) ret_hash);
 	OUTPUT:
 		RETVAL
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
@@ -33,13 +33,14 @@
  *	  ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.58 2004/11/18 21:35:42 tgl Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.59 2004/11/20 19:07:40 tgl Exp $
  *
  **********************************************************************/
 
 #include "postgres.h"
 
 /* system stuff */
+#include <ctype.h>
 #include <fcntl.h>
 #include <unistd.h>
 
@@ -281,6 +282,21 @@ plperl_safe_init(void)
 }
 
 
+/*
+ * Perl likes to put a newline after its error messages; clean up such
+ */
+static char *
+strip_trailing_ws(const char *msg)
+{
+	char   *res = pstrdup(msg);
+	int		len = strlen(res);
+
+	while (len > 0 && isspace((unsigned char) res[len-1]))
+		res[--len] = '\0';
+	return res;
+}
+
+
 static HV *
 plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
 {
@@ -496,7 +512,7 @@ plperl_get_elem(HV *hash, char *key)
 {
 	SV **svp = hv_fetch(hash, key, strlen(key), FALSE);
 	if (!svp)
-		elog(ERROR, "plperl: key '%s' not found", key);
+		elog(ERROR, "plperl: key \"%s\" not found", key);
 	return SvTYPE(*svp) == SVt_NULL ? NULL : SvPV(*svp, PL_na);
 }
 
@@ -533,7 +549,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
 	plkeys = plperl_get_keys(hvNew);
 	natts = av_len(plkeys) + 1;
 	if (natts != tupdesc->natts)
-		elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys.");
+		elog(ERROR, "plperl: $_TD->{new} has an incorrect number of keys");
 
 	modattrs = palloc0(natts * sizeof(int));
 	modvalues = palloc0(natts * sizeof(Datum));
@@ -550,7 +566,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
 		attn = modattrs[i] = SPI_fnumber(tupdesc, platt);
 
 		if (attn == SPI_ERROR_NOATTRIBUTE)
-			elog(ERROR, "plperl: invalid attribute `%s' in tuple.", platt);
+			elog(ERROR, "plperl: invalid attribute \"%s\" in tuple", platt);
 		atti = attn - 1;
 
 		plval = plperl_get_elem(hvNew, platt);
@@ -581,7 +597,7 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup, Oid fn_oid)
 	pfree(modvalues);
 	pfree(modnulls);
 	if (rtup == NULL)
-		elog(ERROR, "plperl: SPI_modifytuple failed -- error:  %d", SPI_result);
+		elog(ERROR, "plperl: SPI_modifytuple failed -- error: %d", SPI_result);
 
 	return rtup;
 }
@@ -690,7 +706,8 @@ plperl_create_sub(char *s, bool trusted)
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
-		elog(ERROR, "creation of function failed: %s", SvPV(ERRSV, PL_na));
+		elog(ERROR, "creation of function failed: %s",
+			 strip_trailing_ws(SvPV(ERRSV, PL_na)));
 	}
 
 	/*
@@ -816,7 +833,8 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
-		elog(ERROR, "error from function: %s", SvPV(ERRSV, PL_na));
+		elog(ERROR, "error from function: %s",
+			 strip_trailing_ws(SvPV(ERRSV, PL_na)));
 	}
 
 	retval = newSVsv(POPs);
@@ -860,7 +878,7 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, S
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
-		elog(ERROR, "plperl: didn't get a return item from function");
+		elog(ERROR, "didn't get a return item from trigger function");
 	}
 
 	if (SvTRUE(ERRSV))
@@ -869,7 +887,8 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo, S
 		PUTBACK;
 		FREETMPS;
 		LEAVE;
-		elog(ERROR, "plperl: error from function: %s", SvPV(ERRSV, PL_na));
+		elog(ERROR, "error from trigger function: %s",
+			 strip_trailing_ws(SvPV(ERRSV, PL_na)));
 	}
 
 	retval = newSVsv(POPs);
