pltcl.c

PostgreSQL7.4.6 for Linux

							  "foreach v $args {\n"
							  "  incr i\n"
							  "  set $i $v\n"
							  "}\n"
							  "unset i v\n\n", -1);
		}

		/************************************************************
		 * Add user's function definition to proc body
		 ************************************************************/
		proc_source = DatumGetCString(DirectFunctionCall1(textout,
								  PointerGetDatum(&procStruct->prosrc)));
		UTF_BEGIN;
		Tcl_DStringAppend(&proc_internal_body, UTF_E2U(proc_source), -1);
		UTF_END;
		pfree(proc_source);
		Tcl_DStringAppendElement(&proc_internal_def,
								 Tcl_DStringValue(&proc_internal_body));
		Tcl_DStringFree(&proc_internal_body);

		/************************************************************
		 * Create the procedure in the interpreter
		 ************************************************************/
		tcl_rc = Tcl_GlobalEval(interp,
								Tcl_DStringValue(&proc_internal_def));
		Tcl_DStringFree(&proc_internal_def);
		if (tcl_rc != TCL_OK)
		{
			free(prodesc->proname);
			free(prodesc);
			elog(ERROR, "could not create internal procedure \"%s\": %s",
				 internal_proname, interp->result);
		}

		/************************************************************
		 * Add the proc description block to the hashtable
		 ************************************************************/
		hashent = Tcl_CreateHashEntry(pltcl_proc_hash,
									  prodesc->proname, &hashnew);
		Tcl_SetHashValue(hashent, (ClientData) prodesc);
	}

	ReleaseSysCache(procTup);

	return prodesc;
}


/**********************************************************************
 * pltcl_elog()		- elog() support for PLTcl
 **********************************************************************/
static int
pltcl_elog(ClientData cdata, Tcl_Interp *interp,
		   int argc, CONST84 char *argv[])
{
	volatile int level;
	sigjmp_buf	save_restart;

	/************************************************************
	 * Suppress messages during the restart process
	 ************************************************************/
	if (pltcl_restart_in_progress)
		return TCL_ERROR;

	if (argc != 3)
	{
		Tcl_SetResult(interp, "syntax error - 'elog level msg'",
					  TCL_VOLATILE);
		return TCL_ERROR;
	}

	if (strcmp(argv[1], "DEBUG") == 0)
		level = DEBUG2;
	else if (strcmp(argv[1], "LOG") == 0)
		level = LOG;
	else if (strcmp(argv[1], "INFO") == 0)
		level = INFO;
	else if (strcmp(argv[1], "NOTICE") == 0)
		level = NOTICE;
	else if (strcmp(argv[1], "WARNING") == 0)
		level = WARNING;
	else if (strcmp(argv[1], "ERROR") == 0)
		level = ERROR;
	else if (strcmp(argv[1], "FATAL") == 0)
		level = FATAL;
	else
	{
		Tcl_AppendResult(interp, "Unknown elog level '", argv[1],
						 "'", NULL);
		return TCL_ERROR;
	}

	/************************************************************
	 * Catch the longjmp from elog() and begin a controlled
	 * return though all interpreter levels if it happens
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		pltcl_restart_in_progress = 1;
		return TCL_ERROR;
	}

	/************************************************************
	 * Call elog(), restore the original restart address
	 * and return to the caller (if no longjmp)
	 ************************************************************/
	UTF_BEGIN;
	elog(level, "%s", UTF_U2E(argv[2]));
	UTF_END;

	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
	return TCL_OK;
}


/**********************************************************************
 * pltcl_quote()	- quote literal strings that are to
 *			  be used in SPI_exec query strings
 **********************************************************************/
static int
pltcl_quote(ClientData cdata, Tcl_Interp *interp,
			int argc, CONST84 char *argv[])
{
	char	   *tmp;
	const char *cp1;
	char	   *cp2;

	/************************************************************
	 * Check call syntax
	 ************************************************************/
	if (argc != 2)
	{
		Tcl_SetResult(interp, "syntax error - 'quote string'", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Allocate space for the maximum the string can
	 * grow to and initialize pointers
	 ************************************************************/
	tmp = palloc(strlen(argv[1]) * 2 + 1);
	cp1 = argv[1];
	cp2 = tmp;

	/************************************************************
	 * Walk through string and double every quote and backslash
	 ************************************************************/
	while (*cp1)
	{
		if (*cp1 == '\'')
			*cp2++ = '\'';
		else
		{
			if (*cp1 == '\\')
				*cp2++ = '\\';
		}
		*cp2++ = *cp1++;
	}

	/************************************************************
	 * Terminate the string and set it as result
	 ************************************************************/
	*cp2 = '\0';
	Tcl_SetResult(interp, tmp, TCL_VOLATILE);
	pfree(tmp);
	return TCL_OK;
}


/**********************************************************************
 * pltcl_argisnull()	- determine if a specific argument is NULL
 **********************************************************************/
static int
pltcl_argisnull(ClientData cdata, Tcl_Interp *interp,
				int argc, CONST84 char *argv[])
{
	int			argno;
	FunctionCallInfo fcinfo = pltcl_current_fcinfo;

	/************************************************************
	 * Check call syntax
	 ************************************************************/
	if (argc != 2)
	{
		Tcl_SetResult(interp, "syntax error - 'argisnull argno'", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Check that we're called as a normal function
	 ************************************************************/
	if (fcinfo == NULL)
	{
		Tcl_SetResult(interp, "argisnull cannot be used in triggers",
					  TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Get the argument number
	 ************************************************************/
	if (Tcl_GetInt(interp, argv[1], &argno) != TCL_OK)
		return TCL_ERROR;

	/************************************************************
	 * Check that the argno is valid
	 ************************************************************/
	argno--;
	if (argno < 0 || argno >= fcinfo->nargs)
	{
		Tcl_SetResult(interp, "argno out of range", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Get the requested NULL state
	 ************************************************************/
	if (PG_ARGISNULL(argno))
		Tcl_SetResult(interp, "1", TCL_VOLATILE);
	else
		Tcl_SetResult(interp, "0", TCL_VOLATILE);

	return TCL_OK;
}


/**********************************************************************
 * pltcl_returnnull()	- Cause a NULL return from a function
 **********************************************************************/
static int
pltcl_returnnull(ClientData cdata, Tcl_Interp *interp,
				 int argc, CONST84 char *argv[])
{
	FunctionCallInfo fcinfo = pltcl_current_fcinfo;

	/************************************************************
	 * Check call syntax
	 ************************************************************/
	if (argc != 1)
	{
		Tcl_SetResult(interp, "syntax error - 'return_null'", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Check that we're called as a normal function
	 ************************************************************/
	if (fcinfo == NULL)
	{
		Tcl_SetResult(interp, "return_null cannot be used in triggers",
					  TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Set the NULL return flag and cause Tcl to return from the
	 * procedure.
	 ************************************************************/
	fcinfo->isnull = true;

	return TCL_RETURN;
}


/**********************************************************************
 * pltcl_SPI_exec()		- The builtin SPI_exec command
 *				  for the Tcl interpreter
 **********************************************************************/
static int
pltcl_SPI_exec(ClientData cdata, Tcl_Interp *interp,
			   int argc, CONST84 char *argv[])
{
	int			spi_rc;
	char		buf[64];
	int			count = 0;
	CONST84 char *volatile arrayname = NULL;
	volatile int query_idx;
	int			i;
	int			loop_rc;
	int			ntuples;
	HeapTuple  *volatile tuples;
	volatile TupleDesc tupdesc = NULL;
	SPITupleTable *tuptable;
	sigjmp_buf	save_restart;

	char	   *usage = "syntax error - 'SPI_exec "
	"?-count n? "
	"?-array name? query ?loop body?";

	/************************************************************
	 * Don't do anything if we are already in restart mode
	 ************************************************************/
	if (pltcl_restart_in_progress)
		return TCL_ERROR;

	/************************************************************
	 * Check the call syntax and get the count option
	 ************************************************************/
	if (argc < 2)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	i = 1;
	while (i < argc)
	{
		if (strcmp(argv[i], "-array") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			arrayname = argv[i++];
			continue;
		}

		if (strcmp(argv[i], "-count") == 0)
		{
			if (++i >= argc)
			{
				Tcl_SetResult(interp, usage, TCL_VOLATILE);
				return TCL_ERROR;
			}
			if (Tcl_GetInt(interp, argv[i++], &count) != TCL_OK)
				return TCL_ERROR;
			continue;
		}

		break;
	}

	query_idx = i;
	if (query_idx >= argc)
	{
		Tcl_SetResult(interp, usage, TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Prepare to start a controlled return through all
	 * interpreter levels on transaction abort
	 ************************************************************/
	memcpy(&save_restart, &Warn_restart, sizeof(save_restart));
	if (sigsetjmp(Warn_restart, 1) != 0)
	{
		memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));
		pltcl_restart_in_progress = 1;
		Tcl_SetResult(interp, "Transaction abort", TCL_VOLATILE);
		return TCL_ERROR;
	}

	/************************************************************
	 * Execute the query and handle return codes
	 ************************************************************/
	UTF_BEGIN;
	spi_rc = SPI_exec(UTF_U2E(argv[query_idx]), count);
	UTF_END;
	memcpy(&Warn_restart, &save_restart, sizeof(Warn_restart));

	switch (spi_rc)
	{
		case SPI_OK_UTILITY:
			Tcl_SetResult(interp, "0", TCL_VOLATILE);
			SPI_freetuptable(SPI_tuptable);
			return TCL_OK;

		case SPI_OK_SELINTO:
		case SPI_OK_INSERT:
		case SPI_OK_DELETE:
		case SPI_OK_UPDATE:
			snprintf(buf, sizeof(buf), "%d", SPI_processed);
			Tcl_SetResult(interp, buf, TCL_VOLATILE);
			SPI_freetuptable(SPI_tuptable);
			return TCL_OK;

		case SPI_OK_SELECT:
			break;

		case SPI_ERROR_ARGUMENT:
			Tcl_SetResult(interp,
						  "pltcl: SPI_exec() failed - SPI_ERROR_ARGUMENT",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_UNCONNECTED:
			Tcl_SetResult(interp,
					  "pltcl: SPI_exec() failed - SPI_ERROR_UNCONNECTED",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_COPY:
			Tcl_SetResult(interp,
						  "pltcl: SPI_exec() failed - SPI_ERROR_COPY",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_CURSOR:
			Tcl_SetResult(interp,
						  "pltcl: SPI_exec() failed - SPI_ERROR_CURSOR",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_TRANSACTION:
			Tcl_SetResult(interp,
					  "pltcl: SPI_exec() failed - SPI_ERROR_TRANSACTION",
						  TCL_VOLATILE);
			return TCL_ERROR;

		case SPI_ERROR_OPUNKNOWN:
			Tcl_SetResult(interp,