Fix plperl and pltcl to include the name of the current function when

passing on errors from the language interpreter.  (plpython seems
fairly OK about this already.)  Per gripe from Robert Kleemann.

src/pl/plperl/expected/plperl.out

@@ -496,4 +496,4 @@ CREATE OR REPLACE FUNCTION perl_spi_prepared_bad(double precision) RETURNS doubl
   return $result;
 $$ LANGUAGE plperl;
 SELECT perl_spi_prepared_bad(4.35) as "double precision";
-ERROR:  error from Perl function: type "does_not_exist" does not exist at line 2.
+ERROR:  error from Perl function "perl_spi_prepared_bad": type "does_not_exist" does not exist at line 2.

src/pl/plperl/expected/plperl_elog.out

@@ -35,7 +35,7 @@ create or replace function uses_global() returns text language plperl as $$
   return 'uses_global worked';
 
 $$;
-ERROR:  creation of Perl function failed: Global symbol "$global" requires explicit package name at line 3.
+ERROR:  creation of Perl function "uses_global" failed: Global symbol "$global" requires explicit package name at line 3.
 Global symbol "$other_global" requires explicit package name at line 4.
 select uses_global();
 ERROR:  function uses_global() does not exist

src/pl/plperl/plperl.c

 /**********************************************************************
  * plperl.c - perl as a procedural language for PostgreSQL
  *
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.129 2007/06/28 17:49:59 tgl Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.130 2007/10/05 17:06:11 tgl Exp $
  *
  **********************************************************************/
 
@@ -39,7 +39,7 @@ PG_MODULE_MAGIC;
  **********************************************************************/
 typedef struct plperl_proc_desc
 {
-	char	   *proname;
+	char	   *proname;		/* user name of procedure */
 	TransactionId fn_xmin;
 	ItemPointerData fn_tid;
 	bool		fn_readonly;
@@ -60,7 +60,7 @@ typedef struct plperl_proc_desc
 
 typedef struct plperl_proc_entry
 {
-	char proc_name[NAMEDATALEN];
+	char proc_name[NAMEDATALEN]; /* internal name, eg __PLPerl_proc_39987 */
 	plperl_proc_desc *proc_data;
 } plperl_proc_entry;
 
@@ -887,7 +887,7 @@ plperl_validator(PG_FUNCTION_ARGS)
  * supplied in s, and returns a reference to the closure.
  */
 static SV  *
-plperl_create_sub(char *s, bool trusted)
+plperl_create_sub(char *proname, char *s, bool trusted)
 {
 	dSP;
 	SV		   *subref;
@@ -941,7 +941,8 @@ plperl_create_sub(char *s, bool trusted)
 		LEAVE;
 		ereport(ERROR,
 				(errcode(ERRCODE_SYNTAX_ERROR),
-				 errmsg("creation of Perl function failed: %s",
+				 errmsg("creation of Perl function \"%s\" failed: %s",
+						proname,
 						strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 	}
 
@@ -1070,7 +1071,8 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 		LEAVE;
 		/* XXX need to find a way to assign an errcode here */
 		ereport(ERROR,
-				(errmsg("error from Perl function: %s",
+				(errmsg("error from Perl function \"%s\": %s",
+						desc->proname,
 						strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 	}
 
@@ -1127,7 +1129,8 @@ plperl_call_perl_trigger_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo,
 		LEAVE;
 		/* XXX need to find a way to assign an errcode here */
 		ereport(ERROR,
-				(errmsg("error from Perl trigger function: %s",
+				(errmsg("error from Perl function \"%s\": %s",
+						desc->proname,
 						strip_trailing_ws(SvPV(ERRSV, PL_na)))));
 	}
 
@@ -1403,7 +1406,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 {
 	HeapTuple	procTup;
 	Form_pg_proc procStruct;
-	char		internal_proname[64];
+	char		internal_proname[NAMEDATALEN];
 	plperl_proc_desc *prodesc = NULL;
 	int			i;
 	plperl_proc_entry *hash_entry;
@@ -1448,10 +1451,11 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 
 		if (!uptodate)
 		{
-			free(prodesc); /* are we leaking memory here? */
+			free(prodesc->proname);
+			free(prodesc);
 			prodesc = NULL;
 			hash_search(plperl_proc_hash, internal_proname,
-						HASH_REMOVE,NULL);
+						HASH_REMOVE, NULL);
 		}
 	}
 
@@ -1482,7 +1486,7 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 					(errcode(ERRCODE_OUT_OF_MEMORY),
 					 errmsg("out of memory")));
 		MemSet(prodesc, 0, sizeof(plperl_proc_desc));
-		prodesc->proname = strdup(internal_proname);
+		prodesc->proname = strdup(NameStr(procStruct->proname));
 		prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
 		prodesc->fn_tid = procTup->t_self;
 
@@ -1628,7 +1632,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 
 		check_interp(prodesc->lanpltrusted);
 
-		prodesc->reference = plperl_create_sub(proc_source, prodesc->lanpltrusted);
+		prodesc->reference = plperl_create_sub(prodesc->proname,
+											   proc_source,
+											   prodesc->lanpltrusted);
 
 		restore_context(oldcontext);
 

src/pl/tcl/pltcl.c

@@ -2,7 +2,7 @@
  * pltcl.c		- PostgreSQL support for Tcl as
  *				  procedural language (PL)
  *
- *	  $PostgreSQL: pgsql/src/pl/tcl/pltcl.c,v 1.114 2007/09/28 22:33:20 momjian Exp $
+ *	  $PostgreSQL: pgsql/src/pl/tcl/pltcl.c,v 1.115 2007/10/05 17:06:11 tgl Exp $
  *
  **********************************************************************/
 
@@ -76,7 +76,8 @@ PG_MODULE_MAGIC;
  **********************************************************************/
 typedef struct pltcl_proc_desc
 {
-	char	   *proname;
+	char	   *user_proname;
+	char	   *internal_proname;
 	TransactionId fn_xmin;
 	ItemPointerData fn_tid;
 	bool		fn_readonly;
@@ -549,7 +550,7 @@ pltcl_func_handler(PG_FUNCTION_ARGS)
 	 ************************************************************/
 	Tcl_DStringInit(&tcl_cmd);
 	Tcl_DStringInit(&list_tmp);
-	Tcl_DStringAppendElement(&tcl_cmd, prodesc->proname);
+	Tcl_DStringAppendElement(&tcl_cmd, prodesc->internal_proname);
 
 	/************************************************************
 	 * Add all call arguments to the command
@@ -636,9 +637,10 @@ pltcl_func_handler(PG_FUNCTION_ARGS)
 		UTF_BEGIN;
 		ereport(ERROR,
 				(errmsg("%s", interp->result),
-				 errcontext("%s",
+				 errcontext("%s\nin PL/Tcl function \"%s\"",
 							UTF_U2E(Tcl_GetVar(interp, "errorInfo",
-											   TCL_GLOBAL_ONLY)))));
+											   TCL_GLOBAL_ONLY)),
+							prodesc->user_proname)));
 		UTF_END;
 	}
 
@@ -723,7 +725,7 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS)
 	PG_TRY();
 	{
 		/* The procedure name */
-		Tcl_DStringAppendElement(&tcl_cmd, prodesc->proname);
+		Tcl_DStringAppendElement(&tcl_cmd, prodesc->internal_proname);
 
 		/* The trigger name for argument TG_name */
 		Tcl_DStringAppendElement(&tcl_cmd, trigdata->tg_trigger->tgname);
@@ -865,9 +867,10 @@ pltcl_trigger_handler(PG_FUNCTION_ARGS)
 		UTF_BEGIN;
 		ereport(ERROR,
 				(errmsg("%s", interp->result),
-				 errcontext("%s",
+				 errcontext("%s\nin PL/Tcl function \"%s\"",
 							UTF_U2E(Tcl_GetVar(interp, "errorInfo",
-											   TCL_GLOBAL_ONLY)))));
+											   TCL_GLOBAL_ONLY)),
+							prodesc->user_proname)));
 		UTF_END;
 	}
 
@@ -1085,7 +1088,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 					(errcode(ERRCODE_OUT_OF_MEMORY),
 					 errmsg("out of memory")));
 		MemSet(prodesc, 0, sizeof(pltcl_proc_desc));
-		prodesc->proname = strdup(internal_proname);
+		prodesc->user_proname = strdup(NameStr(procStruct->proname));
+		prodesc->internal_proname = strdup(internal_proname);
 		prodesc->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data);
 		prodesc->fn_tid = procTup->t_self;
 
@@ -1101,7 +1105,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 								 0, 0, 0);
 		if (!HeapTupleIsValid(langTup))
 		{
-			free(prodesc->proname);
+			free(prodesc->user_proname);
+			free(prodesc->internal_proname);
 			free(prodesc);
 			elog(ERROR, "cache lookup failed for language %u",
 				 procStruct->prolang);
@@ -1126,7 +1131,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 									 0, 0, 0);
 			if (!HeapTupleIsValid(typeTup))
 			{
-				free(prodesc->proname);
+				free(prodesc->user_proname);
+				free(prodesc->internal_proname);
 				free(prodesc);
 				elog(ERROR, "cache lookup failed for type %u",
 					 procStruct->prorettype);
@@ -1140,7 +1146,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 					 /* okay */ ;
 				else if (procStruct->prorettype == TRIGGEROID)
 				{
-					free(prodesc->proname);
+					free(prodesc->user_proname);
+					free(prodesc->internal_proname);
 					free(prodesc);
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
@@ -1148,7 +1155,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 				}
 				else
 				{
-					free(prodesc->proname);
+					free(prodesc->user_proname);
+					free(prodesc->internal_proname);
 					free(prodesc);
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
@@ -1159,7 +1167,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 
 			if (typeStruct->typtype == TYPTYPE_COMPOSITE)
 			{
-				free(prodesc->proname);
+				free(prodesc->user_proname);
+				free(prodesc->internal_proname);
 				free(prodesc);
 				ereport(ERROR,
 						(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
@@ -1187,7 +1196,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 										 0, 0, 0);
 				if (!HeapTupleIsValid(typeTup))
 				{
-					free(prodesc->proname);
+					free(prodesc->user_proname);
+					free(prodesc->internal_proname);
 					free(prodesc);
 					elog(ERROR, "cache lookup failed for type %u",
 						 procStruct->proargtypes.values[i]);
@@ -1197,7 +1207,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 				/* Disallow pseudotype argument */
 				if (typeStruct->typtype == TYPTYPE_PSEUDO)
 				{
-					free(prodesc->proname);
+					free(prodesc->user_proname);
+					free(prodesc->internal_proname);
 					free(prodesc);
 					ereport(ERROR,
 							(errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
@@ -1305,7 +1316,8 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 		Tcl_DStringFree(&proc_internal_def);
 		if (tcl_rc != TCL_OK)
 		{
-			free(prodesc->proname);
+			free(prodesc->user_proname);
+			free(prodesc->internal_proname);
 			free(prodesc);
 			elog(ERROR, "could not create internal procedure \"%s\": %s",
 				 internal_proname, interp->result);
@@ -1315,7 +1327,7 @@ compile_pltcl_function(Oid fn_oid, Oid tgreloid)
 		 * Add the proc description block to the hashtable
 		 ************************************************************/
 		hashent = Tcl_CreateHashEntry(pltcl_proc_hash,
-									  prodesc->proname, &hashnew);
+									  prodesc->internal_proname, &hashnew);
 		Tcl_SetHashValue(hashent, (ClientData) prodesc);
 	}