firebird-mirror/src/jrd/fun.epp

/*
 *	PROGRAM:	JRD Access Method
 *	MODULE:		fun.e
 *	DESCRIPTION:	External Function handling code.
 *
 * The contents of this file are subject to the Interbase Public
 * License Version 1.0 (the "License"); you may not use this file
 * except in compliance with the License. You may obtain a copy
 * of the License at http://www.Inprise.com/IPL.html
 *
 * Software distributed under the License is distributed on an
 * "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express
 * or implied. See the License for the specific language governing
 * rights and limitations under the License.
 *
 * The Original Code was created by Inprise Corporation
 * and its predecessors. Portions created by Inprise Corporation are
 * Copyright (C) Inprise Corporation.
 *
 * All Rights Reserved.
 * Contributor(s): ______________________________________.
 *
 * 2001.9.18 Claudio Valderrama: Allow return parameter by descriptor
 * to signal NULL by testing the flags of the parameter's descriptor.
 *
 * 2002.10.29 Sean Leyne - Removed obsolete "Netware" port
 *
 */
/*
$Id: fun.epp,v 1.19 2003-03-24 13:35:33 brodsom Exp $
*/

#include "firebird.h"
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include "../jrd/jrd.h"
#include "../jrd/val.h"
#include "../jrd/exe.h"
#include "../jrd/gds.h"
#include "../jrd/req.h"
#include "../jrd/lls.h"
#include "../jrd/blb.h"
#include "../jrd/flu.h"
#include "../jrd/common.h"
#include "../jrd/constants.h"
#include "../jrd/ibsetjmp.h"
#include "../jrd/irq.h"
#include "../jrd/all_proto.h"
#include "../jrd/blb_proto.h"
#include "../jrd/cmp_proto.h"
#include "../jrd/dsc_proto.h"
#include "../jrd/err_proto.h"
#include "../jrd/evl_proto.h"
#include "../jrd/exe_proto.h"
#include "../jrd/flu_proto.h"
#include "../jrd/fun_proto.h"
#include "../jrd/gds_proto.h"
#include "../jrd/mov_proto.h"
#include "../jrd/sym_proto.h"
#include "../jrd/thd_proto.h"
#include "../jrd/sch_proto.h"
#include "../jrd/isc_s_proto.h"

#ifdef VMS
#define CALL_UDF(ptr, udftype)     (*(udftype (*)(SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG))(ptr)) (args [0], args[1], args[2], args[3], args [4], args [5], args [6], args [7], args [8], args [9]) 
#else
#define CALL_UDF(ptr, udftype)     ((udftype (*)(SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG, SLONG))(ptr)) (args [0], args[1], args[2], args[3], args [4], args [5], args [6], args [7], args [8], args [9])
#endif

DATABASE DB = FILENAME "ODS.RDB";

#ifdef VMS
extern double MTH$CVT_D_G(), MTH$CVT_G_D();
#endif

#define EXCEPTION_MESSAGE "The user defined function: \t%s\n\t   referencing entrypoint: \t%s\n\t                in module: \t%s\n\tcaused the fatal exception:"

static SSHORT blob_get_segment(BLB, UCHAR *, USHORT, USHORT *);
static void blob_put_segment(BLB, UCHAR *, USHORT);
static SLONG blob_lseek(BLB, USHORT, SLONG);
static SLONG get_scalar_array(fun_repeat *, DSC *, SAD, LLS *);


void DLL_EXPORT FUN_evaluate(FUN function, JRD_NOD node, VLU value)
{
/**************************************
 *
 *	F U N _ e v a l u a t e
 *
 **************************************
 *
 * Functional description
 *	Evaluate a function.
 *
 **************************************/

	SLONG	args[MAX_UDF_ARGUMENTS + 1];
	USHORT	length;
	UCHAR	temp[800];
	STR		temp_string;
	SSHORT	unsup_datatype = 0;

	TDBB tdbb = GET_THREAD_DATA;

	// Start by constructing argument list
	UCHAR* temp_ptr;

	if (function->fun_temp_length < sizeof(temp))
	{
		temp_string = NULL;
		temp_ptr = temp;
		MOVE_CLEAR(temp, sizeof(temp));
	}
	else
	{
		/* Need to align the starting address because it consists of
		   a number of data blocks with aligned length */

		temp_string =
			FB_NEW_RPT(*tdbb->tdbb_default,
				function->fun_temp_length + DOUBLE_ALIGN - 1) str;
		MOVE_CLEAR(temp_string->str_data, temp_string->str_length);
		temp_ptr =
			(UCHAR *) FB_ALIGN((U_IPTR) temp_string->str_data, DOUBLE_ALIGN);
	}

	MOVE_CLEAR(args, sizeof(args));
	SLONG*		arg_ptr		= args;
	LLS			blob_stack	= 0;
	LLS			array_stack = 0;
	JRD_REQ			request		= tdbb->tdbb_request;
	USHORT		null_flag	= (USHORT)(request->req_flags & req_null);
	fun_repeat*	return_ptr	= function->fun_rpt + function->fun_return_arg;
	JRD_NOD*		ptr			= node->nod_arg;

	value->vlu_desc = return_ptr->fun_desc;
	value->vlu_desc.dsc_address = (UCHAR *) & value->vlu_misc;

/* Trap any potential errors */

#pragma FB_COMPILER_MESSAGE("Note that we cannot use C++ EH here for Win32 SS!")
#if !defined(SUPERSERVER) && !defined(WIN_NT)
	try {
#endif

	START_CHECK_FOR_EXCEPTIONS( (TEXT*) function->fun_exception_message);

	// If the return data type is any of the string types,
	// allocate space to hold value


	if (value->vlu_desc.dsc_dtype <= dtype_varying)
	{
		length = value->vlu_desc.dsc_length;
		STR string = value->vlu_string;
		if (string && string->str_length < length) {
			delete string;
			string = NULL;
		}
		if (!string) {
			string = FB_NEW_RPT(*tdbb->tdbb_default, length) str;
			string->str_length = length;
			value->vlu_string = string;
		}
		value->vlu_desc.dsc_address = string->str_data;
	}


	DSC temp_desc;
	double  d;
	double* dp;

	// Process arguments
	const fun_repeat* end = function->fun_rpt + 1 + function->fun_count;
	for (fun_repeat* tail = function->fun_rpt + 1; tail < end; ++tail)
	{
		DSC* input;
		if (tail == return_ptr) {
			input = &value->vlu_desc; /*(DSC*) value;*/
		} else {
			input = EVL_expr(tdbb, *ptr++);
		}
		SLONG**	ap = (SLONG **) arg_ptr;

		// If we're passing data type ISC descriptor, there's
		// nothing left to be done

		if (tail->fun_mechanism == FUN_descriptor) {
			*ap++ = (SLONG *) input;
			arg_ptr = (SLONG *) ap;
			continue;
		}

		temp_desc = tail->fun_desc;
		temp_desc.dsc_address = temp_ptr;
		length = FB_ALIGN(temp_desc.dsc_length, DOUBLE_ALIGN);

		/* If we've got a null argument, just pass zeros (got any better ideas?) */

		if (!input || (request->req_flags & req_null))
		{
			if (tail->fun_mechanism == FUN_value)
			{
				UCHAR* p = (UCHAR *) arg_ptr;
				MOVE_CLEAR(p, (SLONG) length);
				p += length;
				arg_ptr = (SLONG *) p;
				continue;
			}
			else
			{
				MOVE_CLEAR(temp_ptr, (SLONG) length);
			}
		}
		else if ((SSHORT) abs(tail->fun_mechanism) == FUN_scalar_array)
		{
			length = get_scalar_array(tail, input, (SAD)temp_ptr, &array_stack);
		}
		else
		{
			switch (tail->fun_desc.dsc_dtype)
			{
			case dtype_short:
				{
					SSHORT s = MOV_get_long(input,
											(SSHORT) tail->fun_desc.dsc_scale);
					if (tail->fun_mechanism == FUN_value) {
						/* For (apparent) portability reasons, SHORT by value
						 * is always passed as a LONG.  See v3.2 release notes
						 * Passing by value is not supported in SQL due to
						 * these problems, but can still occur in GDML.
						 * 1994-September-28 David Schnepper 
						 */
						*arg_ptr++ = (SLONG) s;
						continue;
					}
					{
						SSHORT* sp = (SSHORT *) temp_ptr;
						*sp = s;
					}
				}
				break;

			case dtype_sql_time:
			case dtype_sql_date:
			case dtype_long:
				{
					SLONG l;
					/* this check added for bug 74193 */
					if (tail->fun_desc.dsc_dtype == dtype_long)
					{
						l =
							MOV_get_long(input,
										 (SSHORT) tail->fun_desc.dsc_scale);
					}
					else
					{
						/* for sql_date and sql_time just move the value to a long, 
						   scale does not mean anything for it */
						l = *((SLONG *) (input->dsc_address));
					}

					if (tail->fun_mechanism == FUN_value)
					{
						*arg_ptr++ = l;
						continue;
					}
					{
						SLONG* lp = (SLONG *) temp_ptr;
						*lp = l;
					}
				}
				break;

			case dtype_int64:
				{
					SINT64* pi64;
					SINT64 i64 =
						MOV_get_int64(input, (SSHORT)tail->fun_desc.dsc_scale);

					if (tail->fun_mechanism == FUN_value)
					{
						pi64 = (SINT64 *) arg_ptr;
						*pi64++ = i64;
						arg_ptr = (SLONG *) pi64;
						continue;
					}
					pi64 = (SINT64 *) temp_ptr;
					*pi64 = i64;
				}
				break;

			case dtype_real:
				{
				float f = (float) MOV_get_double(input);
					if (tail->fun_mechanism == FUN_value)
					{
						/* For (apparent) portability reasons, FLOAT by value
						 * is always passed as a DOUBLE.  See v3.2 release notes
						 * Passing by value is not supported in SQL due to
						 * these problems, but can still occur in GDML.
						 * 1994-September-28 David Schnepper 
						 */
						double* dp = (double *) arg_ptr;
						*dp++ = (double) f;
						arg_ptr = (SLONG *) dp;
						continue;
					}
					float* fp = (float *) temp_ptr;
					*fp = f;
				}
				break;

			case dtype_double:
#ifdef VMS
			case dtype_d_float:
				d = MOV_get_double(input);
				if (tail->fun_desc.dsc_dtype == SPECIAL_DOUBLE)
				{
					d = CNVT_FROM_DFLT(&d);
				}
#else
				d = MOV_get_double(input);
#endif
				if (tail->fun_mechanism == FUN_value)
				{
					dp = (double *) arg_ptr;
					*dp++ = d;
					arg_ptr = (SLONG *) dp;
					continue;
				}
				dp = (double *) temp_ptr;
				*dp = d;
				break;

			case dtype_text:
			case dtype_cstring:
			case dtype_varying:
				if (tail == return_ptr) {
					temp_ptr = value->vlu_desc.dsc_address;
					length = 0;
				}
				else
					MOV_move(input, &temp_desc);
				break;

			/* CVC: There's no other solution for now: timestamp can't be returned
					by value and the other way is to force the user to pass a dummy value as
					an argument to keep the engine happy. So, here's the hack. */
			case dtype_timestamp:
			    if (tail == return_ptr)
				{
					temp_ptr = value->vlu_desc.dsc_address;
					length = sizeof(GDS_TIMESTAMP);
				}
				else
				{
					MOV_move(input, &temp_desc);
				}
				break;

			case dtype_quad:
			case dtype_array:
				MOV_move(input, &temp_desc);
				break;

			case dtype_blob:
				{
				BLOB blob_desc = (BLOB) temp_ptr;
				BLB  blob;
				length = sizeof(struct blob);
				if (tail == return_ptr)
				{
					blob =
						BLB_create(tdbb, tdbb->tdbb_request->req_transaction,
								   (BID) & value->vlu_misc);
				}
				else
				{
					SLONG* blob_id;
					if (request->req_flags & req_null)
					{
						SLONG null_quad[2];
						null_quad[0] = null_quad[1] = 0;
						blob_id = null_quad;
					}
					else
					{
						if (input->dsc_dtype != dtype_quad &&
							input->dsc_dtype != dtype_blob)
						{
							ERR_post(gds_wish_list,
									 gds_arg_gds, gds_blobnotsup,
									 gds_arg_string, "conversion", 0);
						}
						blob_id = (SLONG *) input->dsc_address;
					}
					blob = BLB_open(tdbb,
									tdbb->tdbb_request->req_transaction,
									(BID)blob_id);
				}
				LLS_PUSH(blob, &blob_stack);
				blob_desc->blob_get_segment = (SSHORT (*)())blob_get_segment;
				blob_desc->blob_put_segment = (void (*)())blob_put_segment;
				blob_desc->blob_seek = (SLONG (*)())blob_lseek;
				blob_desc->blob_handle = (int *) blob;
				blob_desc->blob_number_segments = blob->blb_count;
				blob_desc->blob_max_segment = blob->blb_max_segment;
				blob_desc->blob_total_length = blob->blb_length;
				}
				break;

			default:
				assert(FALSE);
				MOV_move(input, &temp_desc);
				break;

			}
		}

		*ap++ = (SLONG *) temp_ptr;
		arg_ptr = (SLONG *) ap;
		temp_ptr += length;
	}

	if (function->fun_return_arg)
	{
		THREAD_EXIT;
		CALL_UDF(function->fun_entrypoint, void);
		THREAD_ENTER;
	}
	else if ((SLONG) return_ptr->fun_mechanism == FUN_value)
	{
		switch (value->vlu_desc.dsc_dtype)
		{
		case dtype_sql_time:
		case dtype_sql_date:
		case dtype_long:
			THREAD_EXIT;
			value->vlu_misc.vlu_long =
				CALL_UDF(function->fun_entrypoint, SLONG);
			THREAD_ENTER;
			break;

		case dtype_short:
			/* For (apparent) portability reasons, SHORT by value
			 * must always be returned as a LONG.  See v3.2 release notes
			 * 1994-September-28 David Schnepper 
			 */
			THREAD_EXIT;
			value->vlu_misc.vlu_short = (SSHORT)
				CALL_UDF(function->fun_entrypoint, SLONG);
			THREAD_ENTER;
			break;

		case dtype_real:
			/* For (apparent) portability reasons, FLOAT by value
			 * must always be returned as a DOUBLE.  See v3.2 release notes
			 * 1994-September-28 David Schnepper 
			 */
			THREAD_EXIT;
			value->vlu_misc.vlu_float = (float)
				CALL_UDF(function->fun_entrypoint, double);
			THREAD_ENTER;
			break;

		case dtype_int64:
			THREAD_EXIT;
			value->vlu_misc.vlu_int64 =
				CALL_UDF(function->fun_entrypoint, SINT64);
			THREAD_ENTER;
			break;

		case dtype_double:
#ifdef VMS
		case dtype_d_float:
#endif
			THREAD_EXIT;
			value->vlu_misc.vlu_double =
				CALL_UDF(function->fun_entrypoint, double);
			THREAD_ENTER;
			break;

		case dtype_timestamp:
		default:
			unsup_datatype = 1;
			break;
		}
	}
	else
	{
		THREAD_EXIT;
		typedef UCHAR* pUCHAR;
		temp_ptr = CALL_UDF(function->fun_entrypoint, pUCHAR);
		THREAD_ENTER;

		if (temp_ptr != NULL)
		{
			/* CVC: Allow processing of return by descriptor.
					The assumption is that the user didn't modify the return type,
					that has no sense after all, because it is carved in stone. */
			if (return_ptr->fun_mechanism == FUN_descriptor)
			{
				temp_ptr = ((DSC*) temp_ptr)->dsc_address;
			}
			if (temp_ptr)
			{
				switch (value->vlu_desc.dsc_dtype)
				{
				case dtype_sql_date:
				case dtype_sql_time:
				case dtype_long:
					value->vlu_misc.vlu_long = *(SLONG *) temp_ptr;
					break;

				case dtype_short:
					value->vlu_misc.vlu_short = *(SSHORT *) temp_ptr;
					break;

				case dtype_real:
					value->vlu_misc.vlu_float = *(float *) temp_ptr;
					break;

				case dtype_int64:
					value->vlu_misc.vlu_int64 = *(SINT64 *) temp_ptr;
					break;

				case dtype_double:
#ifdef VMS
				case dtype_d_float:
#endif
					value->vlu_misc.vlu_double = *(double *) temp_ptr;
					break;

				case dtype_text:
				case dtype_cstring:
				case dtype_varying:
					temp_desc = value->vlu_desc;
					temp_desc.dsc_address = temp_ptr;
					temp_desc.dsc_length = strlen((char*)temp_ptr) + 1;
					MOV_move(&temp_desc, &value->vlu_desc);
					break;

				case dtype_timestamp:
					{
						SLONG* ip = (SLONG *) temp_ptr;
						value->vlu_misc.vlu_dbkey[0] = *ip++;
						value->vlu_misc.vlu_dbkey[1] = *ip;
					}
					break;

				default:
					unsup_datatype = 1;
					break;
				}
				/* check if this is function has the FREE_IT set, if set and
				   return_value is not null, then free the return value */
				if (((SLONG) return_ptr->fun_mechanism < 0) && temp_ptr)
					free(temp_ptr);
			}
		}
	}

	END_CHECK_FOR_EXCEPTIONS((TEXT*)function->fun_exception_message);

	if (unsup_datatype) {
		IBERROR(169);			/* msg 169 return data type not supported */
	}

#if !defined(SUPERSERVER) && !defined(WIN_NT)
	}
	catch (const std::exception&) {
		delete temp_string;
		while (array_stack) {
			delete[] (UCHAR*)LLS_POP(&array_stack);
		}
		ERR_punt();
	}
#endif

	delete temp_string;

	while (blob_stack)
	{
		BLB_close(tdbb, (BLB)LLS_POP(&blob_stack));
	}

	while (array_stack)
	{
		delete[] (UCHAR*)LLS_POP(&array_stack);
	}

	if (temp_ptr == NULL || function->fun_return_arg &&
		return_ptr->fun_mechanism == FUN_descriptor &&
		(value->vlu_desc.dsc_flags & DSC_null))
	{
		request->req_flags |= req_null;
	}
	else
	{
		request->req_flags &= ~req_null;
	}
	request->req_flags |= null_flag;
}


void DLL_EXPORT FUN_fini( TDBB tdbb)
{
/**************************************
 *
 *	F U N _ f i n i
 *
 **************************************
 *
 * Functional description
 *	Unregister interest in external function modules.
 *
 **************************************/
	DBB dbb;

	dbb = tdbb->tdbb_database;

	while (dbb->dbb_modules)
		FLU_unregister_module((MOD) LLS_POP(&dbb->dbb_modules));
}


void DLL_EXPORT FUN_init(void)
{
/**************************************
 *
 *	F U N _ i n i t
 *
 **************************************
 *
 * Functional description
 *	Initialize external function mechanism.
 *
 **************************************/
}


FUN DLL_EXPORT FUN_lookup_function(TEXT * name)
{
/**************************************
 *
 *	F U N _ l o o k u p _ f u n c t i o n
 *
 **************************************
 *
 * Functional description
 *	Lookup function by name.
 *
 **************************************/
	TDBB tdbb;
	DBB dbb;
	BLK request_fun, request_arg;
	FUN function, prior;
	SYM symbol;
	STR string;
	STR exception_msg;
	TEXT *p;
	MOD module;
	LLS stack;
	USHORT count, args, l;
	ULONG length;
	fun_repeat *tail, temp[MAX_UDF_ARGUMENTS + 1];

	tdbb = GET_THREAD_DATA;
	dbb = tdbb->tdbb_database;

/* Start by looking for already defined symbol */
#ifdef V4_THREADING
	V4_JRD_MUTEX_LOCK(dbb->dbb_mutexes + DBB_MUTX_udf);
#endif
	for (symbol = SYM_lookup(name); symbol; symbol = symbol->sym_homonym)
	{
	    if (symbol->sym_type == SYM_fun) {
#ifdef V4_THREADING
			V4_JRD_MUTEX_UNLOCK(dbb->dbb_mutexes + DBB_MUTX_udf);
#endif
			return (FUN) symbol->sym_object;
		}
	}

	prior = NULL;

	request_fun = (BLK) CMP_find_request(tdbb, irq_l_functions, IRQ_REQUESTS);
	request_arg = (BLK) CMP_find_request(tdbb, irq_l_args, IRQ_REQUESTS);

	FOR(REQUEST_HANDLE request_fun) X IN RDB$FUNCTIONS
		WITH X.RDB$FUNCTION_NAME EQ name 
        if (!REQUEST(irq_l_functions))
            REQUEST(irq_l_functions) = request_fun;
		count = args = 0;
		MOVE_CLEAR(temp, (SLONG) sizeof(temp));
		length = 0;
		FOR(REQUEST_HANDLE request_arg) Y IN RDB$FUNCTION_ARGUMENTS
			WITH Y.RDB$FUNCTION_NAME EQ X.RDB$FUNCTION_NAME
				SORTED BY Y.RDB$ARGUMENT_POSITION 

            if (!REQUEST(irq_l_args))
                REQUEST(irq_l_args) = request_arg;
			tail = temp + Y.RDB$ARGUMENT_POSITION;
			tail->fun_mechanism = (FUN_T) Y.RDB$MECHANISM;
			count = MAX(count, Y.RDB$ARGUMENT_POSITION);
			DSC_make_descriptor(&tail->fun_desc, Y.RDB$FIELD_TYPE,
								Y.RDB$FIELD_SCALE, Y.RDB$FIELD_LENGTH,
								Y.RDB$FIELD_SUB_TYPE, Y.RDB$CHARACTER_SET_ID,
								0);

			if (tail->fun_desc.dsc_dtype == dtype_cstring)
				tail->fun_desc.dsc_length++;

			if (Y.RDB$ARGUMENT_POSITION != X.RDB$RETURN_ARGUMENT)
				++args;
			l = FB_ALIGN(tail->fun_desc.dsc_length, DOUBLE_ALIGN);
			if (tail->fun_desc.dsc_dtype == dtype_blob)
				l = sizeof(struct blob);
			length += l;
        END_FOR;
		function = FB_NEW_RPT(*dbb->dbb_permanent, count + 1) fun;
		function->fun_count = count;
		function->fun_args = args;
		function->fun_return_arg = X.RDB$RETURN_ARGUMENT;
		function->fun_type = X.RDB$FUNCTION_TYPE;
		function->fun_temp_length = length;
		MOVE_FAST(temp, function->fun_rpt,
				  (count + 1) * sizeof(fun_repeat));
#ifndef	WIN_NT					/* NT allows blanks in file paths */
		for (p = X.RDB$MODULE_NAME; *p && *p != ' '; p++);
		*p = 0;
#endif
		for (p = X.RDB$ENTRYPOINT; *p && *p != ' '; p++);
		*p = 0;

		/* Prepare the exception message to be used in case this function ever
		   causes an exception.  This is done at this time to save us from preparing
		   (thus allocating) this message every time the function is called. */
		exception_msg =
			FB_NEW_RPT(*dbb->dbb_permanent,
						  strlen(EXCEPTION_MESSAGE) + strlen(name) +
						  strlen(X.RDB$ENTRYPOINT) +
						  strlen(X.RDB$MODULE_NAME) + 1) str;
		sprintf((char*)exception_msg->str_data, EXCEPTION_MESSAGE, name,
				X.RDB$ENTRYPOINT, X.RDB$MODULE_NAME);
		function->fun_exception_message = exception_msg;

		function->fun_entrypoint =
			ISC_lookup_entrypoint(X.RDB$MODULE_NAME, X.RDB$ENTRYPOINT,
								  ISC_EXT_LIB_PATH_ENV);

		if ( (module = FLU_lookup_module(X.RDB$MODULE_NAME)) ) {
			/* Register interest in the module by database. */

			for (stack = dbb->dbb_modules; stack; stack = stack->lls_next)
				if (module == (MOD) stack->lls_object)
					break;

			/* If the module was already registered with this database
			   then decrement the use count that was incremented in
			   ISC_lookup_entrypoint() above. Otherwise push it onto
			   the stack of registered modules. */

			if (stack)
			{
				FLU_unregister_module(module);
			}
			else
			{
				JrdMemoryPool *old_pool;

				old_pool = tdbb->tdbb_default;
				tdbb->tdbb_default = dbb->dbb_permanent;
				LLS_PUSH(module, &dbb->dbb_modules);
				tdbb->tdbb_default = old_pool;
			}
		}

		/* Could not find a function with given MODULE, ENTRYPOINT,
		 * Try the list of internally implemented functions.
		 */
		if (!function->fun_entrypoint)
			function->fun_entrypoint =
				BUILTIN_entrypoint(X.RDB$MODULE_NAME, X.RDB$ENTRYPOINT);

		if (prior) {
			function->fun_homonym = prior->fun_homonym;
			prior->fun_homonym = function;
		}
		else
		{
			prior = function;
			function->fun_symbol = symbol = FB_NEW(*dbb->dbb_permanent) sym;
			symbol->sym_object = (BLK) function;
			string = FB_NEW_RPT(*dbb->dbb_permanent, strlen(name)) str;
			strcpy((char*)string->str_data, name);
			symbol->sym_string = (TEXT *) string->str_data;
			symbol->sym_type = SYM_fun;
			SYM_insert(symbol);
		}
	END_FOR;

	if (!REQUEST(irq_l_functions))
		REQUEST(irq_l_functions) = request_fun;
	if (!REQUEST(irq_l_args))
		REQUEST(irq_l_args) = request_arg;

#ifdef V4_THREADING
	V4_JRD_MUTEX_UNLOCK(dbb->dbb_mutexes + DBB_MUTX_udf);
#endif
	return prior;
}


FUN DLL_EXPORT FUN_resolve(CSB csb, FUN function, JRD_NOD args)
{
/**************************************
 *
 *	F U N _ r e s o l v e
 *
 **************************************
 *
 * Functional description
 *	Resolve instance of potentially overloaded function.
 *
 **************************************/
	FUN best;
	JRD_NOD *ptr, *end;
	DSC arg;
	int best_score, score;
	fun_repeat *tail;
	TDBB tdbb;

	tdbb = GET_THREAD_DATA;

	best = NULL;
	best_score = 0;
	end = args->nod_arg + args->nod_count;

	for (; function; function = function->fun_homonym)
		if (function->fun_entrypoint && function->fun_args == args->nod_count) {
			score = 0;
			for (ptr = args->nod_arg, tail = function->fun_rpt + 1; ptr < end;
				 ptr++, tail++) {
				CMP_get_desc(tdbb, csb, *ptr, &arg);
				if ((SSHORT) abs(tail->fun_mechanism) == FUN_descriptor)
					score += 10;
				else if (tail->fun_desc.dsc_dtype == dtype_blob ||
						 arg.dsc_dtype == dtype_blob) {
					score = 0;
					break;
				}
				else if (tail->fun_desc.dsc_dtype >= arg.dsc_dtype)
					score += 10 - (arg.dsc_dtype - tail->fun_desc.dsc_dtype);
				else
					score += 1;
			}
			if (!best || score > best_score) {
				best_score = score;
				best = function;
			}
		}

	return best;
}


static SLONG blob_lseek( BLB blob, USHORT mode, SLONG offset)
{
/**************************************
 *
 *	b l o b _ l s e e k
 *
 **************************************
 *
 * Functional description
 *	lseek a  a blob segement.  Return the offset 
 *
 **************************************/

	SLONG return_offset;

/* add thread enter and thread_exit wrappers */
	THREAD_ENTER;
	return_offset = BLB_lseek(blob, mode, offset);
	THREAD_EXIT;
	return (return_offset);
}


static void blob_put_segment( BLB blob, UCHAR * buffer, USHORT length)
{
/**************************************
 *
 *	b l o b _ p u t _ s e g m e n t
 *
 **************************************
 *
 * Functional description
 *	Put  segment into a blob.  Return nothing 
 *
 **************************************/
	TDBB tdbb;

/* As this is a call-back from a UDF, must reacquire the
   engine mutex */

	THREAD_ENTER;
	tdbb = GET_THREAD_DATA;
	BLB_put_segment(tdbb, blob, buffer, length);
	THREAD_EXIT;
}


static SSHORT blob_get_segment(
							   BLB blob,
							   UCHAR * buffer,
							   USHORT length, USHORT * return_length)
{
/**************************************
 *
 *	b l o b _ g e t _ s e g m e n t
 *
 **************************************
 *
 * Functional description
 *	Get next segment of a blob.  Return the following:
 *
 *		1	-- Complete segment has been returned.
 *		0	-- End of blob (no data returned).
 *		-1	-- Current segment is incomplete.
 *
 **************************************/
	TDBB tdbb;

/* add thread enter and thread_exit wrappers */
	THREAD_ENTER;
	tdbb = GET_THREAD_DATA;
	*return_length = BLB_get_segment(tdbb, blob, buffer, length);
	THREAD_EXIT;

	if (blob->blb_flags & BLB_eof)
		return 0;

	if (blob->blb_fragment_size)
		return -1;

	return 1;
}


static SLONG get_scalar_array(fun_repeat*	arg,
							  DSC*	value,
							  SAD	scalar_desc,
							  LLS*	stack)
{
/**************************************
 *
 *	g e t _ s c a l a r _ a r r a y
 *
 **************************************
 *
 * Functional description
 *	Get and format a scalar array descriptor, then allocate space
 *	and fetch the array.  If conversion is required, convert.
 *	Return length of array desc.
 *
 **************************************/
	TDBB tdbb;
	BLB blob;
	ADS array_desc;
	SLONG stuff[ADS_LEN(16) / 4], n;
	UCHAR *data, *temp;
	DSC from, to;
	USHORT dimensions;
	ads::ads_repeat *tail1;
	sad::sad_repeat *tail2, *end;

	tdbb = GET_THREAD_DATA;

/* Get first the array descriptor, then the array */

	array_desc = (ADS) stuff;
	blob = BLB_get_array(tdbb,
						tdbb->tdbb_request->req_transaction,
						(BID)value->dsc_address,
						array_desc);
	data = FB_NEW(*getDefaultMemoryPool()) UCHAR[array_desc->ads_total_length];
	BLB_get_data(tdbb, blob, data, array_desc->ads_total_length);
	dimensions = array_desc->ads_dimensions;

/* Convert array, if necessary */

	to = arg->fun_desc;
	from = array_desc->ads_rpt[0].ads_desc;

	if (to.dsc_dtype != from.dsc_dtype ||
		to.dsc_scale != from.dsc_scale || to.dsc_length != from.dsc_length) {
		n = array_desc->ads_count;
		to.dsc_address = temp = FB_NEW(*getDefaultMemoryPool()) UCHAR[(SLONG) to.dsc_length * n];
		from.dsc_address = data;
		for (; n; --n, to.dsc_address += to.dsc_length,
			 from.dsc_address += array_desc->ads_element_length)
				MOV_move(&from, &to);
		delete[] data;
		data = temp;
	}

/* Fill out the scalar array descriptor */

	LLS_PUSH(data, stack);
	scalar_desc->sad_desc = arg->fun_desc;
	scalar_desc->sad_desc.dsc_address = data;
	scalar_desc->sad_dimensions = dimensions;

	for (tail2 = scalar_desc->sad_rpt, end = tail2 + dimensions, tail1 =
		 array_desc->ads_rpt; tail2 < end; ++tail1, ++tail2) {
		tail2->sad_upper = tail1->ads_upper;
		tail2->sad_lower = tail1->ads_lower;
	}

	return sizeof(struct sad) + (dimensions - 1) * sizeof(sad::sad_repeat);
}