Various small improvements and cleanups for PL/Perl.

- Allow (ineffective) use of 'require' in plperl
    If the required module is not already loaded then it dies.
    So "use strict;" now works in plperl.

- Pre-load the feature module if perl >= 5.10.
    So "use feature :5.10;" now works in plperl.

- Stored procedure subs are now given names.
    The names are not visible in ordinary use, but they make
    tools like Devel::NYTProf and Devel::Cover much more useful.

- Simplified and generalized the subroutine creation code.
    Now one code path for generating sub source code, not four.
    Can generate multiple 'use' statements with specific imports
    (which handles plperl.use_strict currently and can easily
    be extended to handle a plperl.use_feature=':5.12' in future).

- Disallows use of Safe version 2.20 which is broken for PL/Perl.
    http://rt.perl.org/rt3/Ticket/Display.html?id=72068

- Assorted minor optimizations by pre-growing data structures.

Patch from Tim Bunce, reviewed by Alex Hunsaker.

1 files changed, 158 insertions, 93 deletions

diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 6daab687c3b..09ffe3047ba 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.160 2010/01/20 01:08:21 adunstan Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.161 2010/01/26 23:11:56 adunstan Exp $
  *
  **********************************************************************/
 
@@ -132,6 +132,7 @@ static InterpState interp_state = INTERP_NONE;
 static PerlInterpreter *plperl_trusted_interp = NULL;
 static PerlInterpreter *plperl_untrusted_interp = NULL;
 static PerlInterpreter *plperl_held_interp = NULL;
+static OP *(*pp_require_orig)(pTHX) = NULL;
 static bool trusted_context;
 static HTAB *plperl_proc_hash = NULL;
 static HTAB *plperl_query_hash = NULL;
@@ -163,11 +164,14 @@ 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 void plperl_create_sub(plperl_proc_desc *desc, char *s);
+static void plperl_create_sub(plperl_proc_desc *desc, char *s, Oid fn_oid);
 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);
+static char *strip_trailing_ws(const char *msg);
+static OP * pp_require_safe(pTHX);
+static int restore_context(bool);
 
 /*
  * Convert an SV to char * and verify the encoding via pg_verifymbstr()
@@ -187,7 +191,7 @@ sv2text_mbverified(SV *sv)
 	 */
 	val = SvPV(sv, len);
 	pg_verifymbstr(val, len, false);
-    return val;
+	return val;
 }
 
 /*
@@ -267,14 +271,21 @@ _PG_init(void)
  * assign that interpreter if it is available to either the trusted or
  * untrusted interpreter. If it has already been assigned, and we need to
  * create the other interpreter, we do that if we can, or error out.
- * We detect if it is safe to run two interpreters during the setup of the
- * dummy interpreter.
  */
 
 
 static void
-check_interp(bool trusted)
+select_perl_context(bool trusted)
 {
+	/*
+	 * handle simple cases
+	 */
+	if (restore_context(trusted))
+		return;
+
+	/*
+	 * adopt held interp if free, else create new one if possible
+	 */
 	if (interp_state == INTERP_HELD)
 	{
 		if (trusted)
@@ -287,23 +298,6 @@ check_interp(bool trusted)
 			plperl_untrusted_interp = plperl_held_interp;
 			interp_state = INTERP_UNTRUSTED;
 		}
-		plperl_held_interp = NULL;
-		trusted_context = trusted;
-		if (trusted) /* done last to avoid recursion */
-			plperl_safe_init();
-	}
-	else if (interp_state == INTERP_BOTH ||
-			 (trusted && interp_state == INTERP_TRUSTED) ||
-			 (!trusted && interp_state == INTERP_UNTRUSTED))
-	{
-		if (trusted_context != trusted)
-		{
-			if (trusted)
-				PERL_SET_CONTEXT(plperl_trusted_interp);
-			else
-				PERL_SET_CONTEXT(plperl_untrusted_interp);
-			trusted_context = trusted;
-		}
 	}
 	else
 	{
@@ -313,32 +307,52 @@ check_interp(bool trusted)
 			plperl_trusted_interp = plperl;
 		else
 			plperl_untrusted_interp = plperl;
-		plperl_held_interp = NULL;
-		trusted_context = trusted;
 		interp_state = INTERP_BOTH;
-		if (trusted) /* done last to avoid recursion */
-			plperl_safe_init();
 #else
 		elog(ERROR,
 			 "cannot allocate second Perl interpreter on this platform");
 #endif
 	}
+	plperl_held_interp = NULL;
+	trusted_context = trusted;
+
+	/*
+	 * initialization - done after plperl_*_interp and trusted_context
+	 * updates above to ensure a clean state (and thereby avoid recursion via
+	 * plperl_safe_init caling plperl_call_perl_func for utf8fix)
+	 */
+	if (trusted) {
+		plperl_safe_init();
+		PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+	}
 }
 
 /*
  * Restore previous interpreter selection, if two are active
  */
-static void
-restore_context(bool old_context)
+static int
+restore_context(bool trusted)
 {
-	if (interp_state == INTERP_BOTH && trusted_context != old_context)
+	if (interp_state == INTERP_BOTH ||
+		( trusted && interp_state == INTERP_TRUSTED) ||
+		(!trusted && interp_state == INTERP_UNTRUSTED))
 	{
-		if (old_context)
-			PERL_SET_CONTEXT(plperl_trusted_interp);
-		else
-			PERL_SET_CONTEXT(plperl_untrusted_interp);
-		trusted_context = old_context;
+		if (trusted_context != trusted)
+		{
+			if (trusted) {
+				PERL_SET_CONTEXT(plperl_trusted_interp);
+				PL_ppaddr[OP_REQUIRE] = pp_require_safe;
+			}
+			else {
+				PERL_SET_CONTEXT(plperl_untrusted_interp);
+				PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+			}
+			trusted_context = trusted;
+		}
+		return 1; /* context restored */
 	}
+
+	return 0;     /* unable - appropriate interpreter not available */
 }
 
 static PerlInterpreter *
@@ -422,6 +436,16 @@ plperl_init_interp(void)
 
 	PERL_SET_CONTEXT(plperl);
 	perl_construct(plperl);
+
+	/*
+	 * Record the original function for the 'require' opcode.
+	 * Ensure it's used for new interpreters.
+	 */
+	if (!pp_require_orig)
+		pp_require_orig = PL_ppaddr[OP_REQUIRE];
+	else
+		PL_ppaddr[OP_REQUIRE] = pp_require_orig;
+
 	perl_parse(plperl, plperl_init_shared_libs,
 			   nargs, embedding, NULL);
 	perl_run(plperl);
@@ -471,26 +495,71 @@ plperl_init_interp(void)
 }
 
 
+/*
+ * Our safe implementation of the require opcode.
+ * This is safe because it's completely unable to load any code.
+ * If the requested file/module has already been loaded it'll return true.
+ * If not, it'll die.
+ * So now "use Foo;" will work iff Foo has already been loaded.
+ */
+static OP *
+pp_require_safe(pTHX)
+{
+	dVAR; dSP;
+	SV *sv, **svp;
+	char *name;
+	STRLEN len;
+
+    sv = POPs;
+    name = SvPV(sv, len);
+    if (!(name && len > 0 && *name))
+        RETPUSHNO;
+
+	svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
+	if (svp && *svp != &PL_sv_undef)
+		RETPUSHYES;
+
+	DIE(aTHX_ "Unable to load %s into plperl", name);
+}
+
+
 static void
 plperl_safe_init(void)
 {
 	SV		   *safe_version_sv;
+	IV			safe_version_x100;
 
 	safe_version_sv = eval_pv(SAFE_MODULE, FALSE);	/* TRUE = croak if failure */
+	safe_version_x100 = (int)(SvNV(safe_version_sv) * 100);
 
 	/*
-	 * We actually want to reject Safe version < 2.09, but it's risky to
-	 * assume that floating-point comparisons are exact, so use a slightly
-	 * smaller comparison value.
+	 * Reject too-old versions of Safe and some others:
+	 * 2.20: http://rt.perl.org/rt3/Ticket/Display.html?id=72068
 	 */
-	if (SvNV(safe_version_sv) < 2.0899)
+	if (safe_version_x100 < 209 || safe_version_x100 == 220)
 	{
 		/* not safe, so disallow all trusted funcs */
 		eval_pv(PLC_SAFE_BAD, FALSE);
+		if (SvTRUE(ERRSV))
+		{
+			ereport(ERROR,
+				(errcode(ERRCODE_INTERNAL_ERROR),
+				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+				 errdetail("While executing PLC_SAFE_BAD")));
+		}
+
 	}
 	else
 	{
 		eval_pv(PLC_SAFE_OK, FALSE);
+		if (SvTRUE(ERRSV))
+		{
+			ereport(ERROR,
+				(errcode(ERRCODE_INTERNAL_ERROR),
+				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV))),
+				 errdetail("While executing PLC_SAFE_OK")));
+		}
+
 		if (GetDatabaseEncoding() == PG_UTF8)
 		{
 			/*
@@ -502,6 +571,7 @@ plperl_safe_init(void)
 			 */
 			plperl_proc_desc desc;
 			FunctionCallInfoData fcinfo;
+			SV *perlret;
 
 			desc.proname = "utf8fix";
 			desc.lanpltrusted = true;
@@ -511,14 +581,16 @@ plperl_safe_init(void)
 
 			/* compile the function */
 			plperl_create_sub(&desc,
-					"return shift =~ /\\xa9/i ? 'true' : 'false' ;");
+					"return shift =~ /\\xa9/i ? 'true' : 'false' ;", 0);
 
 			/* set up to call the function with a single text argument 'a' */
 			fcinfo.arg[0] = CStringGetTextDatum("a");
 			fcinfo.argnull[0] = false;
 
 			/* and make the call */
-			(void) plperl_call_perl_func(&desc, &fcinfo);
+			perlret = plperl_call_perl_func(&desc, &fcinfo);
+
+			SvREFCNT_dec(perlret);
 		}
 	}
 }
@@ -582,7 +654,6 @@ plperl_convert_to_pg_array(SV *src)
 {
 	SV		   *rv;
 	int			count;
-
 	dSP;
 
 	PUSHMARK(SP);
@@ -619,6 +690,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 	HV		   *hv;
 
 	hv = newHV();
+	hv_ksplit(hv, 12); /* pre-grow the hash */
 
 	tdata = (TriggerData *) fcinfo->context;
 	tupdesc = tdata->tg_relation->rd_att;
@@ -673,6 +745,7 @@ plperl_trigger_build_args(FunctionCallInfo fcinfo)
 	{
 		AV		   *av = newAV();
 
+		av_extend(av, tdata->tg_trigger->tgnargs);
 		for (i = 0; i < tdata->tg_trigger->tgnargs; i++)
 			av_push(av, newSVstring(tdata->tg_trigger->tgargs[i]));
 		hv_store_string(hv, "args", newRV_noinc((SV *) av));
@@ -893,9 +966,9 @@ plperl_inline_handler(PG_FUNCTION_ARGS)
 		if (SPI_connect() != SPI_OK_CONNECT)
 			elog(ERROR, "could not connect to SPI manager");
 
-		check_interp(desc.lanpltrusted);
+		select_perl_context(desc.lanpltrusted);
 
-		plperl_create_sub(&desc, codeblock->source_text);
+		plperl_create_sub(&desc, codeblock->source_text, 0);
 
 		if (!desc.reference)	/* can this happen? */
 			elog(ERROR, "could not create internal procedure for anonymous code block");
@@ -1000,23 +1073,33 @@ plperl_validator(PG_FUNCTION_ARGS)
 
 
 /*
- * Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
- * supplied in s, and returns a reference to the closure.
+ * Uses mksafefunc/mkunsafefunc to create a subroutine whose text is
+ * supplied in s, and returns a reference to it
  */
 static void
-plperl_create_sub(plperl_proc_desc *prodesc, char *s)
+plperl_create_sub(plperl_proc_desc *prodesc, char *s, Oid fn_oid)
 {
 	dSP;
 	bool        trusted = prodesc->lanpltrusted;
-	SV		   *subref;
-	int			count;
-	char	   *compile_sub;
+	char        subname[NAMEDATALEN+40];
+	HV         *pragma_hv = newHV();
+	SV         *subref = NULL;
+	int         count;
+	char       *compile_sub;
+
+	sprintf(subname, "%s__%u", prodesc->proname, fn_oid);
+
+	if (plperl_use_strict)
+		hv_store_string(pragma_hv, "strict", (SV*)newAV());
 
 	ENTER;
 	SAVETMPS;
 	PUSHMARK(SP);
-	XPUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=$_[0]; shift;")));
-	XPUSHs(sv_2mortal(newSVstring(s)));
+	EXTEND(SP,4);
+	PUSHs(sv_2mortal(newSVstring(subname)));
+	PUSHs(sv_2mortal(newRV_noinc((SV*)pragma_hv)));
+	PUSHs(sv_2mortal(newSVstring("our $_TD; local $_TD=shift;")));
+	PUSHs(sv_2mortal(newSVstring(s)));
 	PUTBACK;
 
 	/*
@@ -1024,57 +1107,36 @@ plperl_create_sub(plperl_proc_desc *prodesc, char *s)
 	 * errors properly.  Perhaps it's because there's another level of eval
 	 * inside mksafefunc?
 	 */
-
-	if (trusted && plperl_use_strict)
-		compile_sub = "::mk_strict_safefunc";
-	else if (plperl_use_strict)
-		compile_sub = "::mk_strict_unsafefunc";
-	else if (trusted)
-		compile_sub = "::mksafefunc";
-	else
-		compile_sub = "::mkunsafefunc";
-
+	compile_sub = (trusted) ? "::mksafefunc" : "::mkunsafefunc";
 	count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR);
 	SPAGAIN;
 
-	if (count != 1)
-	{
-		PUTBACK;
-		FREETMPS;
-		LEAVE;
-		elog(ERROR, "didn't get a return item from mksafefunc");
+	if (count == 1) {
+		GV *sub_glob = (GV*)POPs;
+		if (sub_glob && SvTYPE(sub_glob) == SVt_PVGV)
+			subref = newRV_inc((SV*)GvCVu((GV*)sub_glob));
 	}
 
-	subref = POPs;
+	PUTBACK;
+	FREETMPS;
+	LEAVE;
 
 	if (SvTRUE(ERRSV))
 	{
-		PUTBACK;
-		FREETMPS;
-		LEAVE;
 		ereport(ERROR,
 				(errcode(ERRCODE_SYNTAX_ERROR),
 				 errmsg("%s", strip_trailing_ws(SvPV_nolen(ERRSV)))));
 	}
 
-	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
+	if (!subref)
 	{
-		PUTBACK;
-		FREETMPS;
-		LEAVE;
-		elog(ERROR, "didn't get a code ref");
+		ereport(ERROR,
+				(errcode(ERRCODE_INTERNAL_ERROR),
+				 errmsg("didn't get a GLOB from compiling %s via %s", prodesc->proname, compile_sub)));
 	}
 
-	/*
-	 * need to make a copy of the return, it comes off the stack as a
-	 * temporary.
-	 */
 	prodesc->reference = newSVsv(subref);
 
-	PUTBACK;
-	FREETMPS;
-	LEAVE;
-
 	return;
 }
 
@@ -1118,13 +1180,14 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 	SAVETMPS;
 
 	PUSHMARK(SP);
+	EXTEND(sp, 1 + desc->nargs);
 
-	XPUSHs(&PL_sv_undef);		/* no trigger data */
+	PUSHs(&PL_sv_undef);		/* no trigger data */
 
 	for (i = 0; i < desc->nargs; i++)
 	{
 		if (fcinfo->argnull[i])
-			XPUSHs(&PL_sv_undef);
+			PUSHs(&PL_sv_undef);
 		else if (desc->arg_is_rowtype[i])
 		{
 			HeapTupleHeader td;
@@ -1144,7 +1207,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 			tmptup.t_data = td;
 
 			hashref = plperl_hash_from_tuple(&tmptup, tupdesc);
-			XPUSHs(sv_2mortal(hashref));
+			PUSHs(sv_2mortal(hashref));
 			ReleaseTupleDesc(tupdesc);
 		}
 		else
@@ -1154,7 +1217,7 @@ plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo)
 			tmp = OutputFunctionCall(&(desc->arg_out_func[i]),
 									 fcinfo->arg[i]);
 			sv = newSVstring(tmp);
-			XPUSHs(sv_2mortal(sv));
+			PUSHs(sv_2mortal(sv));
 			pfree(tmp);
 		}
 	}
@@ -1293,7 +1356,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
 							"cannot accept a set")));
 	}
 
-	check_interp(prodesc->lanpltrusted);
+	select_perl_context(prodesc->lanpltrusted);
 
 	perlret = plperl_call_perl_func(prodesc, fcinfo);
 
@@ -1440,7 +1503,7 @@ plperl_trigger_handler(PG_FUNCTION_ARGS)
 	pl_error_context.arg = prodesc->proname;
 	error_context_stack = &pl_error_context;
 
-	check_interp(prodesc->lanpltrusted);
+	select_perl_context(prodesc->lanpltrusted);
 
 	svTD = plperl_trigger_build_args(fcinfo);
 	perlret = plperl_call_perl_trigger_func(prodesc, fcinfo, svTD);
@@ -1757,9 +1820,9 @@ compile_plperl_function(Oid fn_oid, bool is_trigger)
 		 * Create the procedure in the interpreter
 		 ************************************************************/
 
-		check_interp(prodesc->lanpltrusted);
+		select_perl_context(prodesc->lanpltrusted);
 
-		plperl_create_sub(prodesc, proc_source);
+		plperl_create_sub(prodesc, proc_source, fn_oid);
 
 		restore_context(oldcontext);
 
@@ -1795,6 +1858,7 @@ plperl_hash_from_tuple(HeapTuple tuple, TupleDesc tupdesc)
 	int			i;
 
 	hv = newHV();
+	hv_ksplit(hv, tupdesc->natts); /* pre-grow the hash */
 
 	for (i = 0; i < tupdesc->natts; i++)
 	{
@@ -1922,6 +1986,7 @@ plperl_spi_execute_fetch_result(SPITupleTable *tuptable, int processed,
 		int			i;
 
 		rows = newAV();
+		av_extend(rows, processed);
 		for (i = 0; i < processed; i++)
 		{
 			row = plperl_hash_from_tuple(tuptable->vals[i], tuptable->tupdesc);