Sync source code from Tizen:BaseHEAD2.0_alphamaster2.0alpha1.0_post

1 files changed, 817 insertions, 0 deletions

diff --git a/tcl/tcl_internal.c b/tcl/tcl_internal.c
new file mode 100644
index 0000000..d5a3e99
--- /dev/null
+++ b/tcl/tcl_internal.c
@@ -0,0 +1,817 @@
+/*-
+ * See the file LICENSE for redistribution information.
+ *
+ * Copyright (c) 1999-2009 Oracle.  All rights reserved.
+ *
+ * $Id$
+ */
+
+#include "db_config.h"
+
+#include "db_int.h"
+#ifdef HAVE_SYSTEM_INCLUDE_FILES
+#include <tcl.h>
+#endif
+#include "dbinc/tcl_db.h"
+#include "dbinc/db_page.h"
+#include "dbinc/db_am.h"
+
+/*
+ *
+ * internal.c --
+ *
+ *	This file contains internal functions we need to maintain
+ *	state for our Tcl interface.
+ *
+ *	NOTE: This all uses a linear linked list.  If we end up with
+ *	too many info structs such that this is a performance hit, it
+ *	should be redone using hashes or a list per type.  The assumption
+ *	is that the user won't have more than a few dozen info structs
+ *	in operation at any given point in time.  Even a complicated
+ *	application with a few environments, nested transactions, locking,
+ *	and several databases open, using cursors should not have a
+ *	negative performance impact, in terms of searching the list to
+ *	get/manipulate the info structure.
+ */
+
+#define	GLOB_CHAR(c)	((c) == '*' || (c) == '?')
+
+/*
+ * PUBLIC: DBTCL_INFO *_NewInfo __P((Tcl_Interp *,
+ * PUBLIC:    void *, char *, enum INFOTYPE));
+ *
+ * _NewInfo --
+ *
+ * This function will create a new info structure and fill it in
+ * with the name and pointer, id and type.
+ */
+DBTCL_INFO *
+_NewInfo(interp, anyp, name, type)
+	Tcl_Interp *interp;
+	void *anyp;
+	char *name;
+	enum INFOTYPE type;
+{
+	DBTCL_INFO *p;
+	int ret;
+
+	if ((ret = __os_calloc(NULL, sizeof(DBTCL_INFO), 1, &p)) != 0) {
+		Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
+		return (NULL);
+	}
+
+	if ((ret = __os_strdup(NULL, name, &p->i_name)) != 0) {
+		Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
+		__os_free(NULL, p);
+		return (NULL);
+	}
+	p->i_interp = interp;
+	p->i_anyp = anyp;
+	p->i_type = type;
+
+	LIST_INSERT_HEAD(&__db_infohead, p, entries);
+	return (p);
+}
+
+/*
+ * PUBLIC: void *_NameToPtr __P((CONST char *));
+ */
+void	*
+_NameToPtr(name)
+	CONST char *name;
+{
+	DBTCL_INFO *p;
+
+	LIST_FOREACH(p, &__db_infohead, entries)
+		if (strcmp(name, p->i_name) == 0)
+			return (p->i_anyp);
+	return (NULL);
+}
+
+/*
+ * PUBLIC: DBTCL_INFO *_PtrToInfo __P((CONST void *));
+ */
+DBTCL_INFO *
+_PtrToInfo(ptr)
+	CONST void *ptr;
+{
+	DBTCL_INFO *p;
+
+	LIST_FOREACH(p, &__db_infohead, entries)
+		if (p->i_anyp == ptr)
+			return (p);
+	return (NULL);
+}
+
+/*
+ * PUBLIC: DBTCL_INFO *_NameToInfo __P((CONST char *));
+ */
+DBTCL_INFO *
+_NameToInfo(name)
+	CONST char *name;
+{
+	DBTCL_INFO *p;
+
+	LIST_FOREACH(p, &__db_infohead, entries)
+		if (strcmp(name, p->i_name) == 0)
+			return (p);
+	return (NULL);
+}
+
+/*
+ * PUBLIC: void  _SetInfoData __P((DBTCL_INFO *, void *));
+ */
+void
+_SetInfoData(p, data)
+	DBTCL_INFO *p;
+	void *data;
+{
+	if (p == NULL)
+		return;
+	p->i_anyp = data;
+	return;
+}
+
+/*
+ * PUBLIC: void  _DeleteInfo __P((DBTCL_INFO *));
+ */
+void
+_DeleteInfo(p)
+	DBTCL_INFO *p;
+{
+	if (p == NULL)
+		return;
+	LIST_REMOVE(p, entries);
+	if (p->i_lockobj.data != NULL)
+		__os_free(NULL, p->i_lockobj.data);
+	if (p->i_err != NULL && p->i_err != stderr && p->i_err != stdout) {
+		(void)fclose(p->i_err);
+		p->i_err = NULL;
+	}
+	if (p->i_errpfx != NULL)
+		__os_free(NULL, p->i_errpfx);
+	if (p->i_compare != NULL) {
+		Tcl_DecrRefCount(p->i_compare);
+	}
+	if (p->i_dupcompare != NULL) {
+		Tcl_DecrRefCount(p->i_dupcompare);
+	}
+	if (p->i_hashproc != NULL) {
+		Tcl_DecrRefCount(p->i_hashproc);
+	}
+	if (p->i_part_callback != NULL) {
+		Tcl_DecrRefCount(p->i_part_callback);
+	}
+	if (p->i_second_call != NULL) {
+		Tcl_DecrRefCount(p->i_second_call);
+	}
+	if (p->i_rep_eid != NULL) {
+		Tcl_DecrRefCount(p->i_rep_eid);
+	}
+	if (p->i_rep_send != NULL) {
+		Tcl_DecrRefCount(p->i_rep_send);
+	}
+	if (p->i_event != NULL) {
+		Tcl_DecrRefCount(p->i_event);
+	}
+	__os_free(NULL, p->i_name);
+	__os_free(NULL, p);
+
+	return;
+}
+
+/*
+ * PUBLIC: int _SetListElem __P((Tcl_Interp *,
+ * PUBLIC:    Tcl_Obj *, void *, u_int32_t, void *, u_int32_t));
+ */
+int
+_SetListElem(interp, list, elem1, e1cnt, elem2, e2cnt)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	void *elem1, *elem2;
+	u_int32_t e1cnt, e2cnt;
+{
+	Tcl_Obj *myobjv[2], *thislist;
+	int myobjc;
+
+	myobjc = 2;
+	myobjv[0] = Tcl_NewByteArrayObj((u_char *)elem1, (int)e1cnt);
+	myobjv[1] = Tcl_NewByteArrayObj((u_char *)elem2, (int)e2cnt);
+	thislist = Tcl_NewListObj(myobjc, myobjv);
+	if (thislist == NULL)
+		return (TCL_ERROR);
+	return (Tcl_ListObjAppendElement(interp, list, thislist));
+
+}
+
+/*
+ * PUBLIC: int _SetListElemInt __P((Tcl_Interp *, Tcl_Obj *, void *, long));
+ */
+int
+_SetListElemInt(interp, list, elem1, elem2)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	void *elem1;
+	long elem2;
+{
+	Tcl_Obj *myobjv[2], *thislist;
+	int myobjc;
+
+	myobjc = 2;
+	myobjv[0] =
+	    Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1));
+	myobjv[1] = Tcl_NewLongObj(elem2);
+	thislist = Tcl_NewListObj(myobjc, myobjv);
+	if (thislist == NULL)
+		return (TCL_ERROR);
+	return (Tcl_ListObjAppendElement(interp, list, thislist));
+}
+
+/*
+ * Don't compile this code if we don't have sequences compiled into the DB
+ * library, it's likely because we don't have a 64-bit type, and trying to
+ * use int64_t is going to result in syntax errors.
+ */
+#ifdef HAVE_64BIT_TYPES
+/*
+ * PUBLIC: int _SetListElemWideInt __P((Tcl_Interp *,
+ * PUBLIC:     Tcl_Obj *, void *, int64_t));
+ */
+int
+_SetListElemWideInt(interp, list, elem1, elem2)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	void *elem1;
+	int64_t elem2;
+{
+	Tcl_Obj *myobjv[2], *thislist;
+	int myobjc;
+
+	myobjc = 2;
+	myobjv[0] =
+	    Tcl_NewByteArrayObj((u_char *)elem1, (int)strlen((char *)elem1));
+	myobjv[1] = Tcl_NewWideIntObj(elem2);
+	thislist = Tcl_NewListObj(myobjc, myobjv);
+	if (thislist == NULL)
+		return (TCL_ERROR);
+	return (Tcl_ListObjAppendElement(interp, list, thislist));
+}
+#endif /* HAVE_64BIT_TYPES */
+
+/*
+ * PUBLIC: int _SetListRecnoElem __P((Tcl_Interp *, Tcl_Obj *,
+ * PUBLIC:     db_recno_t, u_char *, u_int32_t));
+ */
+int
+_SetListRecnoElem(interp, list, elem1, elem2, e2size)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	db_recno_t elem1;
+	u_char *elem2;
+	u_int32_t e2size;
+{
+	Tcl_Obj *myobjv[2], *thislist;
+	int myobjc;
+
+	myobjc = 2;
+	myobjv[0] = Tcl_NewWideIntObj((Tcl_WideInt)elem1);
+	myobjv[1] = Tcl_NewByteArrayObj(elem2, (int)e2size);
+	thislist = Tcl_NewListObj(myobjc, myobjv);
+	if (thislist == NULL)
+		return (TCL_ERROR);
+	return (Tcl_ListObjAppendElement(interp, list, thislist));
+
+}
+
+/*
+ * _Set3DBTList --
+ *	This is really analogous to both _SetListElem and
+ *	_SetListRecnoElem--it's used for three-DBT lists returned by
+ *	DB->pget and DBC->pget().  We'd need a family of four functions
+ *	to handle all the recno/non-recno cases, however, so we make
+ *	this a little more aware of the internals and do the logic inside.
+ *
+ *	XXX
+ *	One of these days all these functions should probably be cleaned up
+ *	to eliminate redundancy and bring them into the standard DB
+ *	function namespace.
+ *
+ * PUBLIC: int _Set3DBTList __P((Tcl_Interp *, Tcl_Obj *, DBT *, int,
+ * PUBLIC:     DBT *, int, DBT *));
+ */
+int
+_Set3DBTList(interp, list, elem1, is1recno, elem2, is2recno, elem3)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	DBT *elem1, *elem2, *elem3;
+	int is1recno, is2recno;
+{
+
+	Tcl_Obj *myobjv[3], *thislist;
+
+	if (is1recno)
+		myobjv[0] = Tcl_NewWideIntObj(
+		    (Tcl_WideInt)*(db_recno_t *)elem1->data);
+	else
+		myobjv[0] = Tcl_NewByteArrayObj(
+		    (u_char *)elem1->data, (int)elem1->size);
+
+	if (is2recno)
+		myobjv[1] = Tcl_NewWideIntObj(
+		    (Tcl_WideInt)*(db_recno_t *)elem2->data);
+	else
+		myobjv[1] = Tcl_NewByteArrayObj(
+		    (u_char *)elem2->data, (int)elem2->size);
+
+	myobjv[2] = Tcl_NewByteArrayObj(
+	    (u_char *)elem3->data, (int)elem3->size);
+
+	thislist = Tcl_NewListObj(3, myobjv);
+
+	if (thislist == NULL)
+		return (TCL_ERROR);
+	return (Tcl_ListObjAppendElement(interp, list, thislist));
+}
+
+/*
+ * _SetMultiList -- build a list for return from multiple get.
+ *
+ * PUBLIC: int _SetMultiList __P((Tcl_Interp *,
+ * PUBLIC:	    Tcl_Obj *, DBT *, DBT*, DBTYPE, u_int32_t));
+ */
+int
+_SetMultiList(interp, list, key, data, type, flag)
+	Tcl_Interp *interp;
+	Tcl_Obj *list;
+	DBT *key, *data;
+	DBTYPE type;
+	u_int32_t flag;
+{
+	db_recno_t recno;
+	u_int32_t dlen, klen;
+	int result;
+	void *pointer, *dp, *kp;
+
+	recno = 0;
+	dlen = 0;
+	kp = NULL;
+
+	DB_MULTIPLE_INIT(pointer, data);
+	result = TCL_OK;
+
+	if (type == DB_RECNO || type == DB_QUEUE)
+		recno = *(db_recno_t *) key->data;
+	else
+		kp = key->data;
+	klen = key->size;
+	do {
+		if (flag & DB_MULTIPLE_KEY) {
+			if (type == DB_RECNO || type == DB_QUEUE)
+				DB_MULTIPLE_RECNO_NEXT(pointer,
+				    data, recno, dp, dlen);
+			else
+				DB_MULTIPLE_KEY_NEXT(pointer,
+				    data, kp, klen, dp, dlen);
+		} else
+			DB_MULTIPLE_NEXT(pointer, data, dp, dlen);
+
+		if (pointer == NULL)
+			break;
+
+		if (type == DB_RECNO || type == DB_QUEUE) {
+			result =
+			    _SetListRecnoElem(interp, list, recno, dp, dlen);
+			recno++;
+			/* Wrap around and skip zero. */
+			if (recno == 0)
+				recno++;
+		} else
+			result = _SetListElem(interp, list, kp, klen, dp, dlen);
+	} while (result == TCL_OK);
+
+	return (result);
+}
+/*
+ * PUBLIC: int _GetGlobPrefix __P((char *, char **));
+ */
+int
+_GetGlobPrefix(pattern, prefix)
+	char *pattern;
+	char **prefix;
+{
+	int i, j;
+	char *p;
+
+	/*
+	 * Duplicate it, we get enough space and most of the work is done.
+	 */
+	if (__os_strdup(NULL, pattern, prefix) != 0)
+		return (1);
+
+	p = *prefix;
+	for (i = 0, j = 0; p[i] && !GLOB_CHAR(p[i]); i++, j++)
+		/*
+		 * Check for an escaped character and adjust
+		 */
+		if (p[i] == '\\' && p[i+1]) {
+			p[j] = p[i+1];
+			i++;
+		} else
+			p[j] = p[i];
+	p[j] = 0;
+	return (0);
+}
+
+/*
+ * PUBLIC: int _ReturnSetup __P((Tcl_Interp *, int, int, char *));
+ */
+int
+_ReturnSetup(interp, ret, ok, errmsg)
+	Tcl_Interp *interp;
+	int ret, ok;
+	char *errmsg;
+{
+	char *msg;
+
+	if (ret > 0)
+		return (_ErrorSetup(interp, ret, errmsg));
+
+	/*
+	 * We either have success or a DB error.  If a DB error, set up the
+	 * string.  We return an error if not one of the errors we catch.
+	 * If anyone wants to reset the result to return anything different,
+	 * then the calling function is responsible for doing so via
+	 * Tcl_ResetResult or another Tcl_SetObjResult.
+	 */
+	if (ret == 0) {
+		Tcl_SetResult(interp, "0", TCL_STATIC);
+		return (TCL_OK);
+	}
+
+	msg = db_strerror(ret);
+	Tcl_AppendResult(interp, msg, NULL);
+
+	if (ok)
+		return (TCL_OK);
+	else {
+		Tcl_SetErrorCode(interp, "BerkeleyDB", msg, NULL);
+		return (TCL_ERROR);
+	}
+}
+
+/*
+ * PUBLIC: int _ErrorSetup __P((Tcl_Interp *, int, char *));
+ */
+int
+_ErrorSetup(interp, ret, errmsg)
+	Tcl_Interp *interp;
+	int ret;
+	char *errmsg;
+{
+	Tcl_SetErrno(ret);
+	Tcl_AppendResult(interp, errmsg, ":", Tcl_PosixError(interp), NULL);
+	return (TCL_ERROR);
+}
+
+/*
+ * PUBLIC: void _ErrorFunc __P((const DB_ENV *, CONST char *, const char *));
+ */
+void
+_ErrorFunc(dbenv, pfx, msg)
+	const DB_ENV *dbenv;
+	CONST char *pfx;
+	const char *msg;
+{
+	DBTCL_INFO *p;
+	Tcl_Interp *interp;
+	size_t size;
+	char *err;
+
+	COMPQUIET(dbenv, NULL);
+
+	p = _NameToInfo(pfx);
+	if (p == NULL)
+		return;
+	interp = p->i_interp;
+
+	size = strlen(pfx) + strlen(msg) + 4;
+	/*
+	 * If we cannot allocate enough to put together the prefix
+	 * and message then give them just the message.
+	 */
+	if (__os_malloc(NULL, size, &err) != 0) {
+		Tcl_AddErrorInfo(interp, msg);
+		Tcl_AppendResult(interp, msg, "\n", NULL);
+		return;
+	}
+	snprintf(err, size, "%s: %s", pfx, msg);
+	Tcl_AddErrorInfo(interp, err);
+	Tcl_AppendResult(interp, err, "\n", NULL);
+	__os_free(NULL, err);
+	return;
+}
+
+/*
+ * PUBLIC: void _EventFunc __P((DB_ENV *, u_int32_t, void *));
+ */
+void
+_EventFunc(dbenv, event, info)
+	DB_ENV *dbenv;
+	u_int32_t event;
+	void *info;
+{
+#define	TCLDB_EVENTITEMS 2	/* Event name and any info */
+#define	TCLDB_SENDEVENT 3	/* Event Tcl proc, env name, event objects. */
+	DBTCL_INFO *ip;
+	Tcl_Interp *interp;
+	Tcl_Obj *event_o, *origobj;
+	Tcl_Obj *myobjv[TCLDB_EVENTITEMS], *objv[TCLDB_SENDEVENT];
+	int i, myobjc, result;
+
+	ip = (DBTCL_INFO *)dbenv->app_private;
+	interp = ip->i_interp;
+	if (ip->i_event == NULL)
+		return;
+	objv[0] = ip->i_event;
+	objv[1] = NewStringObj(ip->i_name, strlen(ip->i_name));
+
+	/*
+	 * Most events don't have additional info.  Assume none
+	 * and handle individually those that do.
+	 */
+	myobjv[1] = NULL;
+	myobjc = 1;
+	switch (event) {
+	case DB_EVENT_PANIC:
+		/*
+		 * Info is the original error code.
+		 */
+		myobjv[0] = NewStringObj("panic", strlen("panic"));
+		myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info);
+		break;
+	case DB_EVENT_REP_CLIENT:
+		myobjv[0] = NewStringObj("rep_client", strlen("rep_client"));
+		break;
+	case DB_EVENT_REP_ELECTED:
+		myobjv[0] = NewStringObj("elected", strlen("elected"));
+		break;
+	case DB_EVENT_REP_MASTER:
+		myobjv[0] = NewStringObj("rep_master", strlen("rep_master"));
+		break;
+	case DB_EVENT_REP_NEWMASTER:
+		/*
+		 * Info is the EID of the new master.
+		 */
+		myobjv[0] = NewStringObj("newmaster", strlen("newmaster"));
+		myobjv[myobjc++] = Tcl_NewIntObj(*(int *)info);
+		break;
+	case DB_EVENT_REP_PERM_FAILED:
+		myobjv[0] = NewStringObj("perm_failed", strlen("perm_failed"));
+		break;
+	case DB_EVENT_REP_STARTUPDONE:
+		myobjv[0] = NewStringObj("startupdone", strlen("startupdone"));
+		break;
+	case DB_EVENT_WRITE_FAILED:
+		myobjv[0] =
+		    NewStringObj("write_failed", strlen("write_failed"));
+		break;
+	default:
+		__db_errx(dbenv->env, "Tcl unknown event %lu", (u_long)event);
+		return;
+	}
+
+	for (i = 0; i < myobjc; i++)
+		Tcl_IncrRefCount(myobjv[i]);
+
+	event_o = Tcl_NewListObj(myobjc, myobjv);
+	Tcl_IncrRefCount(event_o);
+	objv[2] = event_o;
+
+	/*
+	 * We really want to return the original result to the
+	 * user.  So, save the result obj here, and then after
+	 * we've taken care of the Tcl_EvalObjv, set the result
+	 * back to this original result.
+	 */
+	origobj = Tcl_GetObjResult(interp);
+	Tcl_IncrRefCount(origobj);
+	result = Tcl_EvalObjv(interp, TCLDB_SENDEVENT, objv, 0);
+	if (result != TCL_OK) {
+		/*
+		 * XXX
+		 * This probably isn't the right error behavior, but
+		 * this error should only happen if the Tcl callback is
+		 * somehow invalid, which is a fatal scripting bug.
+		 * The event handler is a void function so we either
+		 * just return or abort.
+		 * For now, abort.
+		 */
+		__db_errx(dbenv->env, "Tcl event failure");
+		__os_abort(dbenv->env);
+	}
+
+	Tcl_SetObjResult(interp, origobj);
+	Tcl_DecrRefCount(origobj);
+	for (i = 0; i < myobjc; i++)
+		Tcl_DecrRefCount(myobjv[i]);
+	Tcl_DecrRefCount(event_o);
+
+	return;
+}
+
+#define	INVALID_LSNMSG "Invalid LSN with %d parts. Should have 2.\n"
+
+/*
+ * PUBLIC: int _GetLsn __P((Tcl_Interp *, Tcl_Obj *, DB_LSN *));
+ */
+int
+_GetLsn(interp, obj, lsn)
+	Tcl_Interp *interp;
+	Tcl_Obj *obj;
+	DB_LSN *lsn;
+{
+	Tcl_Obj **myobjv;
+	char msg[MSG_SIZE];
+	int myobjc, result;
+	u_int32_t tmp;
+
+	result = Tcl_ListObjGetElements(interp, obj, &myobjc, &myobjv);
+	if (result == TCL_ERROR)
+		return (result);
+	if (myobjc != 2) {
+		result = TCL_ERROR;
+		snprintf(msg, MSG_SIZE, INVALID_LSNMSG, myobjc);
+		Tcl_SetResult(interp, msg, TCL_VOLATILE);
+		return (result);
+	}
+	result = _GetUInt32(interp, myobjv[0], &tmp);
+	if (result == TCL_ERROR)
+		return (result);
+	lsn->file = tmp;
+	result = _GetUInt32(interp, myobjv[1], &tmp);
+	lsn->offset = tmp;
+	return (result);
+}
+
+/*
+ * _GetUInt32 --
+ *	Get a u_int32_t from a Tcl object.  Tcl_GetIntFromObj does the
+ * right thing most of the time, but on machines where a long is 8 bytes
+ * and an int is 4 bytes, it errors on integers between the maximum
+ * int32_t and the maximum u_int32_t.  This is correct, but we generally
+ * want a u_int32_t in the end anyway, so we use Tcl_GetLongFromObj and do
+ * the bounds checking ourselves.
+ *
+ * This code looks much like Tcl_GetIntFromObj, only with a different
+ * bounds check.  It's essentially Tcl_GetUnsignedIntFromObj, which
+ * unfortunately doesn't exist.
+ *
+ * PUBLIC: int _GetUInt32 __P((Tcl_Interp *, Tcl_Obj *, u_int32_t *));
+ */
+int
+_GetUInt32(interp, obj, resp)
+	Tcl_Interp *interp;
+	Tcl_Obj *obj;
+	u_int32_t *resp;
+{
+	int result;
+	long ltmp;
+
+	result = Tcl_GetLongFromObj(interp, obj, &ltmp);
+	if (result != TCL_OK)
+		return (result);
+
+	if ((unsigned long)ltmp != (u_int32_t)ltmp) {
+		if (interp != NULL) {
+			Tcl_ResetResult(interp);
+			Tcl_AppendToObj(Tcl_GetObjResult(interp),
+			    "integer value too large for u_int32_t", -1);
+		}
+		return (TCL_ERROR);
+	}
+
+	*resp = (u_int32_t)ltmp;
+	return (TCL_OK);
+}
+
+/*
+ * _GetFlagsList --
+ *	Get a new Tcl object, containing a list of the string values
+ * associated with a particular set of flag values.
+ *
+ * PUBLIC: Tcl_Obj *_GetFlagsList __P((Tcl_Interp *, u_int32_t, const FN *));
+ */
+Tcl_Obj *
+_GetFlagsList(interp, flags, fnp)
+	Tcl_Interp *interp;
+	u_int32_t flags;
+	const FN *fnp;
+{
+	Tcl_Obj *newlist, *newobj;
+	int result;
+
+	newlist = Tcl_NewObj();
+
+	/*
+	 * If the Berkeley DB library wasn't compiled with statistics, then
+	 * we may get a NULL reference.
+	 */
+	if (fnp == NULL)
+		return (newlist);
+
+	/*
+	 * Append a Tcl_Obj containing each pertinent flag string to the
+	 * specified Tcl list.
+	 */
+	for (; fnp->mask != 0; ++fnp)
+		if (LF_ISSET(fnp->mask)) {
+			newobj = NewStringObj(fnp->name, strlen(fnp->name));
+			result =
+			    Tcl_ListObjAppendElement(interp, newlist, newobj);
+
+			/*
+			 * Tcl_ListObjAppendElement is defined to return TCL_OK
+			 * unless newlist isn't actually a list (or convertible
+			 * into one).  If this is the case, we screwed up badly
+			 * somehow.
+			 */
+			DB_ASSERT(NULL, result == TCL_OK);
+		}
+
+	return (newlist);
+}
+
+int __debug_stop, __debug_on, __debug_print, __debug_test;
+
+/*
+ * PUBLIC: void _debug_check  __P((void));
+ */
+void
+_debug_check()
+{
+	if (__debug_on == 0)
+		return;
+
+	if (__debug_print != 0) {
+		printf("\r%7d:", __debug_on);
+		(void)fflush(stdout);
+	}
+	if (__debug_on++ == __debug_test || __debug_stop)
+		__db_loadme();
+}
+
+/*
+ * XXX
+ * Tcl 8.1+ Tcl_GetByteArrayFromObj/Tcl_GetIntFromObj bug.
+ *
+ * There is a bug in Tcl 8.1+ and byte arrays in that if it happens
+ * to use an object as both a byte array and something else like
+ * an int, and you've done a Tcl_GetByteArrayFromObj, then you
+ * do a Tcl_GetIntFromObj, your memory is deleted.
+ *
+ * Workaround is for all byte arrays we want to use, if it can be
+ * represented as an integer, we copy it so that we don't lose the
+ * memory.
+ */
+/*
+ * PUBLIC: int _CopyObjBytes  __P((Tcl_Interp *, Tcl_Obj *obj, void *,
+ * PUBLIC:     u_int32_t *, int *));
+ */
+int
+_CopyObjBytes(interp, obj, newp, sizep, freep)
+	Tcl_Interp *interp;
+	Tcl_Obj *obj;
+	void *newp;
+	u_int32_t *sizep;
+	int *freep;
+{
+	void *tmp, *new;
+	int i, len, ret;
+
+	/*
+	 * If the object is not an int, then just return the byte
+	 * array because it won't be transformed out from under us.
+	 * If it is a number, we need to copy it.
+	 */
+	*freep = 0;
+	ret = Tcl_GetIntFromObj(interp, obj, &i);
+	tmp = Tcl_GetByteArrayFromObj(obj, &len);
+	*sizep = (u_int32_t)len;
+	if (ret == TCL_ERROR) {
+		Tcl_ResetResult(interp);
+		*(void **)newp = tmp;
+		return (0);
+	}
+
+	/*
+	 * If we get here, we have an integer that might be reused
+	 * at some other point so we cannot count on GetByteArray
+	 * keeping our pointer valid.
+	 */
+	if ((ret = __os_malloc(NULL, (size_t)len, &new)) != 0)
+		return (ret);
+	memcpy(new, tmp, (size_t)len);
+	*(void **)newp = new;
+	*freep = 1;
+	return (0);
+}