Add a validator function for plperl. Andrew Dunstan

2 files changed, 48 insertions, 6 deletions

diff --git a/src/bin/scripts/createlang.c b/src/bin/scripts/createlang.c
index e8015089c9a..d088dad4f97 100644
--- a/src/bin/scripts/createlang.c
+++ b/src/bin/scripts/createlang.c
@@ -5,7 +5,7 @@
  * Portions Copyright (c) 1996-2005, PostgreSQL Global Development Group
  * Portions Copyright (c) 1994, Regents of the University of California
  *
- * $PostgreSQL: pgsql/src/bin/scripts/createlang.c,v 1.16 2005/06/14 02:57:45 momjian Exp $
+ * $PostgreSQL: pgsql/src/bin/scripts/createlang.c,v 1.17 2005/06/22 16:45:50 tgl Exp $
  *
  *-------------------------------------------------------------------------
  */
@@ -191,12 +191,14 @@ main(int argc, char *argv[])
 	{
 		trusted = true;
 		handler = "plperl_call_handler";
+		validator = "plperl_validator";
 		object = "plperl";
 	}
 	else if (strcmp(langname, "plperlu") == 0)
 	{
 		trusted = false;
 		handler = "plperl_call_handler";
+		validator = "plperl_validator";
 		object = "plperl";
 	}
 	else if (strcmp(langname, "plpythonu") == 0)
diff --git a/src/pl/plperl/plperl.c b/src/pl/plperl/plperl.c
index 36fc656ca97..7d0e00effe1 100644
--- a/src/pl/plperl/plperl.c
+++ b/src/pl/plperl/plperl.c
@@ -33,7 +33,7 @@
  *	  ENHANCEMENTS, OR MODIFICATIONS.
  *
  * IDENTIFICATION
- *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.77 2005/06/15 00:35:16 momjian Exp $
+ *	  $PostgreSQL: pgsql/src/pl/plperl/plperl.c,v 1.78 2005/06/22 16:45:51 tgl Exp $
  *
  **********************************************************************/
 
@@ -114,6 +114,7 @@ static void plperl_init_all(void);
 static void plperl_init_interp(void);
 
 Datum		plperl_call_handler(PG_FUNCTION_ARGS);
+Datum		plperl_validator(PG_FUNCTION_ARGS);
 void		plperl_init(void);
 
 HV		   *plperl_spi_exec(char *query, int limit);
@@ -506,10 +507,11 @@ plperl_modify_tuple(HV *hvTD, TriggerData *tdata, HeapTuple otup)
 }
 
 
-/* This is the only externally-visible part of the plperl interface.
+/*
+ * This is the only externally-visible part of the plperl call interface.
  * The Postgres function and trigger managers call it to execute a
- * perl function. */
-
+ * perl function.
+ */
 PG_FUNCTION_INFO_V1(plperl_call_handler);
 
 Datum
@@ -541,6 +543,44 @@ plperl_call_handler(PG_FUNCTION_ARGS)
 	return retval;
 }
 
+/*
+ * This is the other externally visible function - it is called when CREATE
+ * FUNCTION is issued to validate the function being created/replaced.
+ */
+PG_FUNCTION_INFO_V1(plperl_validator);
+
+Datum
+plperl_validator(PG_FUNCTION_ARGS)
+{
+	Oid			funcoid = PG_GETARG_OID(0);
+	HeapTuple	tuple;
+	Form_pg_proc proc;
+	bool		istrigger = false;
+	plperl_proc_desc *prodesc;
+
+	plperl_init_all();
+
+	/* Get the new function's pg_proc entry */
+	tuple = SearchSysCache(PROCOID,
+						   ObjectIdGetDatum(funcoid),
+						   0, 0, 0);
+	if (!HeapTupleIsValid(tuple))
+		elog(ERROR, "cache lookup failed for function %u", funcoid);
+	proc = (Form_pg_proc) GETSTRUCT(tuple);
+
+	/* we assume OPAQUE with no arguments means a trigger */
+	if (proc->prorettype == TRIGGEROID ||
+		(proc->prorettype == OPAQUEOID && proc->pronargs == 0))
+		istrigger = true;
+
+	ReleaseSysCache(tuple);
+
+	prodesc = compile_plperl_function(funcoid, istrigger);
+
+	/* the result of a validator is ignored */
+	PG_RETURN_VOID();
+}
+
 
 /* Uses mksafefunc/mkunsafefunc to create an anonymous sub whose text is
  * supplied in s, and returns a reference to the closure. */
@@ -600,7 +640,7 @@ plperl_create_sub(char *s, bool trusted)
 	 */
 	subref = newSVsv(POPs);
 
-	if (!SvROK(subref))
+	if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV)
 	{
 		PUTBACK;
 		FREETMPS;