summaryrefslogtreecommitdiff
path: root/storage/bdb/tcl/tcl_lock.c
diff options
context:
space:
mode:
Diffstat (limited to 'storage/bdb/tcl/tcl_lock.c')
-rw-r--r--storage/bdb/tcl/tcl_lock.c739
1 files changed, 739 insertions, 0 deletions
diff --git a/storage/bdb/tcl/tcl_lock.c b/storage/bdb/tcl/tcl_lock.c
new file mode 100644
index 00000000000..6cb96dbb0da
--- /dev/null
+++ b/storage/bdb/tcl/tcl_lock.c
@@ -0,0 +1,739 @@
+/*-
+ * See the file LICENSE for redistribution information.
+ *
+ * Copyright (c) 1999-2001
+ * Sleepycat Software. All rights reserved.
+ */
+
+#include "db_config.h"
+
+#ifndef lint
+static const char revid[] = "$Id: tcl_lock.c,v 11.47 2002/08/08 15:27:10 bostic Exp $";
+#endif /* not lint */
+
+#ifndef NO_SYSTEM_INCLUDES
+#include <sys/types.h>
+
+#include <stdlib.h>
+#include <string.h>
+#include <tcl.h>
+#endif
+
+#include "db_int.h"
+#include "dbinc/tcl_db.h"
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+static int lock_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
+static int _LockMode __P((Tcl_Interp *, Tcl_Obj *, db_lockmode_t *));
+static int _GetThisLock __P((Tcl_Interp *, DB_ENV *, u_int32_t,
+ u_int32_t, DBT *, db_lockmode_t, char *));
+static void _LockPutInfo __P((Tcl_Interp *, db_lockop_t, DB_LOCK *,
+ u_int32_t, DBT *));
+#if CONFIG_TEST
+static char *lkmode[] = {
+ "ng",
+ "read",
+ "write",
+ "iwrite",
+ "iread",
+ "iwr",
+ NULL
+};
+enum lkmode {
+ LK_NG,
+ LK_READ,
+ LK_WRITE,
+ LK_IWRITE,
+ LK_IREAD,
+ LK_IWR
+};
+
+/*
+ * tcl_LockDetect --
+ *
+ * PUBLIC: int tcl_LockDetect __P((Tcl_Interp *, int,
+ * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_LockDetect(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+ static char *ldopts[] = {
+ "expire",
+ "default",
+ "maxlocks",
+ "minlocks",
+ "minwrites",
+ "oldest",
+ "random",
+ "youngest",
+ NULL
+ };
+ enum ldopts {
+ LD_EXPIRE,
+ LD_DEFAULT,
+ LD_MAXLOCKS,
+ LD_MINLOCKS,
+ LD_MINWRITES,
+ LD_OLDEST,
+ LD_RANDOM,
+ LD_YOUNGEST
+ };
+ u_int32_t flag, policy;
+ int i, optindex, result, ret;
+
+ result = TCL_OK;
+ flag = policy = 0;
+ i = 2;
+ while (i < objc) {
+ if (Tcl_GetIndexFromObj(interp, objv[i],
+ ldopts, "option", TCL_EXACT, &optindex) != TCL_OK)
+ return (IS_HELP(objv[i]));
+ i++;
+ switch ((enum ldopts)optindex) {
+ case LD_EXPIRE:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_EXPIRE;
+ break;
+ case LD_DEFAULT:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_DEFAULT;
+ break;
+ case LD_MAXLOCKS:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_MAXLOCKS;
+ break;
+ case LD_MINWRITES:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_MINWRITE;
+ break;
+ case LD_MINLOCKS:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_MINLOCKS;
+ break;
+ case LD_OLDEST:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_OLDEST;
+ break;
+ case LD_YOUNGEST:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_YOUNGEST;
+ break;
+ case LD_RANDOM:
+ FLAG_CHECK(policy);
+ policy = DB_LOCK_RANDOM;
+ break;
+ }
+ }
+
+ _debug_check();
+ ret = envp->lock_detect(envp, flag, policy, NULL);
+ result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock detect");
+ return (result);
+}
+
+/*
+ * tcl_LockGet --
+ *
+ * PUBLIC: int tcl_LockGet __P((Tcl_Interp *, int,
+ * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_LockGet(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+ static char *lgopts[] = {
+ "-nowait",
+ NULL
+ };
+ enum lgopts {
+ LGNOWAIT
+ };
+ DBT obj;
+ Tcl_Obj *res;
+ void *otmp;
+ db_lockmode_t mode;
+ u_int32_t flag, lockid;
+ int freeobj, optindex, result, ret;
+ char newname[MSG_SIZE];
+
+ result = TCL_OK;
+ freeobj = 0;
+ memset(newname, 0, MSG_SIZE);
+ if (objc != 5 && objc != 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-nowait? mode id obj");
+ return (TCL_ERROR);
+ }
+ /*
+ * Work back from required args.
+ * Last arg is obj.
+ * Second last is lock id.
+ * Third last is lock mode.
+ */
+ memset(&obj, 0, sizeof(obj));
+
+ if ((result =
+ _GetUInt32(interp, objv[objc-2], &lockid)) != TCL_OK)
+ return (result);
+
+ ret = _CopyObjBytes(interp, objv[objc-1], &otmp,
+ &obj.size, &freeobj);
+ if (ret != 0) {
+ result = _ReturnSetup(interp, ret,
+ DB_RETOK_STD(ret), "lock get");
+ return (result);
+ }
+ obj.data = otmp;
+ if ((result = _LockMode(interp, objv[(objc - 3)], &mode)) != TCL_OK)
+ goto out;
+
+ /*
+ * Any left over arg is the flag.
+ */
+ flag = 0;
+ if (objc == 6) {
+ if (Tcl_GetIndexFromObj(interp, objv[(objc - 4)],
+ lgopts, "option", TCL_EXACT, &optindex) != TCL_OK)
+ return (IS_HELP(objv[(objc - 4)]));
+ switch ((enum lgopts)optindex) {
+ case LGNOWAIT:
+ flag |= DB_LOCK_NOWAIT;
+ break;
+ }
+ }
+
+ result = _GetThisLock(interp, envp, lockid, flag, &obj, mode, newname);
+ if (result == TCL_OK) {
+ res = Tcl_NewStringObj(newname, strlen(newname));
+ Tcl_SetObjResult(interp, res);
+ }
+out:
+ if (freeobj)
+ (void)__os_free(envp, otmp);
+ return (result);
+}
+
+/*
+ * tcl_LockStat --
+ *
+ * PUBLIC: int tcl_LockStat __P((Tcl_Interp *, int,
+ * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_LockStat(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+ DB_LOCK_STAT *sp;
+ Tcl_Obj *res;
+ int result, ret;
+
+ result = TCL_OK;
+ /*
+ * No args for this. Error if there are some.
+ */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return (TCL_ERROR);
+ }
+ _debug_check();
+ ret = envp->lock_stat(envp, &sp, 0);
+ result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock stat");
+ if (result == TCL_ERROR)
+ return (result);
+ /*
+ * Have our stats, now construct the name value
+ * list pairs and free up the memory.
+ */
+ res = Tcl_NewObj();
+ /*
+ * MAKE_STAT_LIST assumes 'res' and 'error' label.
+ */
+ MAKE_STAT_LIST("Region size", sp->st_regsize);
+ MAKE_STAT_LIST("Last allocated locker ID", sp->st_id);
+ MAKE_STAT_LIST("Current maximum unused locker ID", sp->st_cur_maxid);
+ MAKE_STAT_LIST("Maximum locks", sp->st_maxlocks);
+ MAKE_STAT_LIST("Maximum lockers", sp->st_maxlockers);
+ MAKE_STAT_LIST("Maximum objects", sp->st_maxobjects);
+ MAKE_STAT_LIST("Lock modes", sp->st_nmodes);
+ MAKE_STAT_LIST("Current number of locks", sp->st_nlocks);
+ MAKE_STAT_LIST("Maximum number of locks so far", sp->st_maxnlocks);
+ MAKE_STAT_LIST("Current number of lockers", sp->st_nlockers);
+ MAKE_STAT_LIST("Maximum number of lockers so far", sp->st_maxnlockers);
+ MAKE_STAT_LIST("Current number of objects", sp->st_nobjects);
+ MAKE_STAT_LIST("Maximum number of objects so far", sp->st_maxnobjects);
+ MAKE_STAT_LIST("Number of conflicts", sp->st_nconflicts);
+ MAKE_STAT_LIST("Lock requests", sp->st_nrequests);
+ MAKE_STAT_LIST("Lock releases", sp->st_nreleases);
+ MAKE_STAT_LIST("Lock requests that would have waited", sp->st_nnowaits);
+ MAKE_STAT_LIST("Deadlocks detected", sp->st_ndeadlocks);
+ MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
+ MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
+ MAKE_STAT_LIST("Lock timeout value", sp->st_locktimeout);
+ MAKE_STAT_LIST("Number of lock timeouts", sp->st_nlocktimeouts);
+ MAKE_STAT_LIST("Transaction timeout value", sp->st_txntimeout);
+ MAKE_STAT_LIST("Number of transaction timeouts", sp->st_ntxntimeouts);
+ Tcl_SetObjResult(interp, res);
+error:
+ free(sp);
+ return (result);
+}
+
+/*
+ * tcl_LockTimeout --
+ *
+ * PUBLIC: int tcl_LockTimeout __P((Tcl_Interp *, int,
+ * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_LockTimeout(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+ long timeout;
+ int result, ret;
+
+ /*
+ * One arg, the timeout.
+ */
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?timeout?");
+ return (TCL_ERROR);
+ }
+ result = Tcl_GetLongFromObj(interp, objv[2], &timeout);
+ if (result != TCL_OK)
+ return (result);
+ _debug_check();
+ ret = envp->set_timeout(envp, (u_int32_t)timeout, DB_SET_LOCK_TIMEOUT);
+ result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock timeout");
+ return (result);
+}
+
+/*
+ * lock_Cmd --
+ * Implements the "lock" widget.
+ */
+static int
+lock_Cmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Lock handle */
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+{
+ static char *lkcmds[] = {
+ "put",
+ NULL
+ };
+ enum lkcmds {
+ LKPUT
+ };
+ DB_ENV *env;
+ DB_LOCK *lock;
+ DBTCL_INFO *lkip;
+ int cmdindex, result, ret;
+
+ Tcl_ResetResult(interp);
+ lock = (DB_LOCK *)clientData;
+ lkip = _PtrToInfo((void *)lock);
+ result = TCL_OK;
+
+ if (lock == NULL) {
+ Tcl_SetResult(interp, "NULL lock", TCL_STATIC);
+ return (TCL_ERROR);
+ }
+ if (lkip == NULL) {
+ Tcl_SetResult(interp, "NULL lock info pointer", TCL_STATIC);
+ return (TCL_ERROR);
+ }
+
+ env = NAME_TO_ENV(lkip->i_parent->i_name);
+ /*
+ * No args for this. Error if there are some.
+ */
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return (TCL_ERROR);
+ }
+ /*
+ * Get the command name index from the object based on the dbcmds
+ * defined above.
+ */
+ if (Tcl_GetIndexFromObj(interp,
+ objv[1], lkcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
+ return (IS_HELP(objv[1]));
+
+ switch ((enum lkcmds)cmdindex) {
+ case LKPUT:
+ _debug_check();
+ ret = env->lock_put(env, lock);
+ result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
+ "lock put");
+ (void)Tcl_DeleteCommand(interp, lkip->i_name);
+ _DeleteInfo(lkip);
+ __os_free(env, lock);
+ break;
+ }
+ return (result);
+}
+
+/*
+ * tcl_LockVec --
+ *
+ * PUBLIC: int tcl_LockVec __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_LockVec(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* environment pointer */
+{
+ static char *lvopts[] = {
+ "-nowait",
+ NULL
+ };
+ enum lvopts {
+ LVNOWAIT
+ };
+ static char *lkops[] = {
+ "get",
+ "put",
+ "put_all",
+ "put_obj",
+ "timeout",
+ NULL
+ };
+ enum lkops {
+ LKGET,
+ LKPUT,
+ LKPUTALL,
+ LKPUTOBJ,
+ LKTIMEOUT
+ };
+ DB_LOCK *lock;
+ DB_LOCKREQ list;
+ DBT obj;
+ Tcl_Obj **myobjv, *res, *thisop;
+ void *otmp;
+ u_int32_t flag, lockid;
+ int freeobj, i, myobjc, optindex, result, ret;
+ char *lockname, msg[MSG_SIZE], newname[MSG_SIZE];
+
+ result = TCL_OK;
+ memset(newname, 0, MSG_SIZE);
+ flag = 0;
+ freeobj = 0;
+
+ /*
+ * If -nowait is given, it MUST be first arg.
+ */
+ if (Tcl_GetIndexFromObj(interp, objv[2],
+ lvopts, "option", TCL_EXACT, &optindex) == TCL_OK) {
+ switch ((enum lvopts)optindex) {
+ case LVNOWAIT:
+ flag |= DB_LOCK_NOWAIT;
+ break;
+ }
+ i = 3;
+ } else {
+ if (IS_HELP(objv[2]) == TCL_OK)
+ return (TCL_OK);
+ Tcl_ResetResult(interp);
+ i = 2;
+ }
+
+ /*
+ * Our next arg MUST be the locker ID.
+ */
+ result = _GetUInt32(interp, objv[i++], &lockid);
+ if (result != TCL_OK)
+ return (result);
+
+ /*
+ * All other remaining args are operation tuples.
+ * Go through sequentially to decode, execute and build
+ * up list of return values.
+ */
+ res = Tcl_NewListObj(0, NULL);
+ while (i < objc) {
+ /*
+ * Get the list of the tuple.
+ */
+ lock = NULL;
+ result = Tcl_ListObjGetElements(interp, objv[i],
+ &myobjc, &myobjv);
+ if (result == TCL_OK)
+ i++;
+ else
+ break;
+ /*
+ * First we will set up the list of requests.
+ * We will make a "second pass" after we get back
+ * the results from the lock_vec call to create
+ * the return list.
+ */
+ if (Tcl_GetIndexFromObj(interp, myobjv[0],
+ lkops, "option", TCL_EXACT, &optindex) != TCL_OK) {
+ result = IS_HELP(myobjv[0]);
+ goto error;
+ }
+ switch ((enum lkops)optindex) {
+ case LKGET:
+ if (myobjc != 3) {
+ Tcl_WrongNumArgs(interp, 1, myobjv,
+ "{get obj mode}");
+ result = TCL_ERROR;
+ goto error;
+ }
+ result = _LockMode(interp, myobjv[2], &list.mode);
+ if (result != TCL_OK)
+ goto error;
+ ret = _CopyObjBytes(interp, myobjv[1], &otmp,
+ &obj.size, &freeobj);
+ if (ret != 0) {
+ result = _ReturnSetup(interp, ret,
+ DB_RETOK_STD(ret), "lock vec");
+ return (result);
+ }
+ obj.data = otmp;
+ ret = _GetThisLock(interp, envp, lockid, flag,
+ &obj, list.mode, newname);
+ if (ret != 0) {
+ result = _ReturnSetup(interp, ret,
+ DB_RETOK_STD(ret), "lock vec");
+ thisop = Tcl_NewIntObj(ret);
+ (void)Tcl_ListObjAppendElement(interp, res,
+ thisop);
+ goto error;
+ }
+ thisop = Tcl_NewStringObj(newname, strlen(newname));
+ (void)Tcl_ListObjAppendElement(interp, res, thisop);
+ if (freeobj) {
+ (void)__os_free(envp, otmp);
+ freeobj = 0;
+ }
+ continue;
+ case LKPUT:
+ if (myobjc != 2) {
+ Tcl_WrongNumArgs(interp, 1, myobjv,
+ "{put lock}");
+ result = TCL_ERROR;
+ goto error;
+ }
+ list.op = DB_LOCK_PUT;
+ lockname = Tcl_GetStringFromObj(myobjv[1], NULL);
+ lock = NAME_TO_LOCK(lockname);
+ if (lock == NULL) {
+ snprintf(msg, MSG_SIZE, "Invalid lock: %s\n",
+ lockname);
+ Tcl_SetResult(interp, msg, TCL_VOLATILE);
+ result = TCL_ERROR;
+ goto error;
+ }
+ list.lock = *lock;
+ break;
+ case LKPUTALL:
+ if (myobjc != 1) {
+ Tcl_WrongNumArgs(interp, 1, myobjv,
+ "{put_all}");
+ result = TCL_ERROR;
+ goto error;
+ }
+ list.op = DB_LOCK_PUT_ALL;
+ break;
+ case LKPUTOBJ:
+ if (myobjc != 2) {
+ Tcl_WrongNumArgs(interp, 1, myobjv,
+ "{put_obj obj}");
+ result = TCL_ERROR;
+ goto error;
+ }
+ list.op = DB_LOCK_PUT_OBJ;
+ ret = _CopyObjBytes(interp, myobjv[1], &otmp,
+ &obj.size, &freeobj);
+ if (ret != 0) {
+ result = _ReturnSetup(interp, ret,
+ DB_RETOK_STD(ret), "lock vec");
+ return (result);
+ }
+ obj.data = otmp;
+ list.obj = &obj;
+ break;
+ case LKTIMEOUT:
+ list.op = DB_LOCK_TIMEOUT;
+ break;
+
+ }
+ /*
+ * We get here, we have set up our request, now call
+ * lock_vec.
+ */
+ _debug_check();
+ ret = envp->lock_vec(envp, lockid, flag, &list, 1, NULL);
+ /*
+ * Now deal with whether or not the operation succeeded.
+ * Get's were done above, all these are only puts.
+ */
+ thisop = Tcl_NewIntObj(ret);
+ result = Tcl_ListObjAppendElement(interp, res, thisop);
+ if (ret != 0 && result == TCL_OK)
+ result = _ReturnSetup(interp, ret,
+ DB_RETOK_STD(ret), "lock put");
+ if (freeobj) {
+ (void)__os_free(envp, otmp);
+ freeobj = 0;
+ }
+ /*
+ * We did a put of some kind. Since we did that,
+ * we have to delete the commands associated with
+ * any of the locks we just put.
+ */
+ _LockPutInfo(interp, list.op, lock, lockid, &obj);
+ }
+
+ if (result == TCL_OK && res)
+ Tcl_SetObjResult(interp, res);
+error:
+ return (result);
+}
+
+static int
+_LockMode(interp, obj, mode)
+ Tcl_Interp *interp;
+ Tcl_Obj *obj;
+ db_lockmode_t *mode;
+{
+ int optindex;
+
+ if (Tcl_GetIndexFromObj(interp, obj, lkmode, "option",
+ TCL_EXACT, &optindex) != TCL_OK)
+ return (IS_HELP(obj));
+ switch ((enum lkmode)optindex) {
+ case LK_NG:
+ *mode = DB_LOCK_NG;
+ break;
+ case LK_READ:
+ *mode = DB_LOCK_READ;
+ break;
+ case LK_WRITE:
+ *mode = DB_LOCK_WRITE;
+ break;
+ case LK_IREAD:
+ *mode = DB_LOCK_IREAD;
+ break;
+ case LK_IWRITE:
+ *mode = DB_LOCK_IWRITE;
+ break;
+ case LK_IWR:
+ *mode = DB_LOCK_IWR;
+ break;
+ }
+ return (TCL_OK);
+}
+
+static void
+_LockPutInfo(interp, op, lock, lockid, objp)
+ Tcl_Interp *interp;
+ db_lockop_t op;
+ DB_LOCK *lock;
+ u_int32_t lockid;
+ DBT *objp;
+{
+ DBTCL_INFO *p, *nextp;
+ int found;
+
+ for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
+ found = 0;
+ nextp = LIST_NEXT(p, entries);
+ if ((op == DB_LOCK_PUT && (p->i_lock == lock)) ||
+ (op == DB_LOCK_PUT_ALL && p->i_locker == lockid) ||
+ (op == DB_LOCK_PUT_OBJ && p->i_lockobj.data &&
+ memcmp(p->i_lockobj.data, objp->data, objp->size) == 0))
+ found = 1;
+ if (found) {
+ (void)Tcl_DeleteCommand(interp, p->i_name);
+ __os_free(NULL, p->i_lock);
+ _DeleteInfo(p);
+ }
+ }
+}
+
+static int
+_GetThisLock(interp, envp, lockid, flag, objp, mode, newname)
+ Tcl_Interp *interp; /* Interpreter */
+ DB_ENV *envp; /* Env handle */
+ u_int32_t lockid; /* Locker ID */
+ u_int32_t flag; /* Lock flag */
+ DBT *objp; /* Object to lock */
+ db_lockmode_t mode; /* Lock mode */
+ char *newname; /* New command name */
+{
+ DB_LOCK *lock;
+ DBTCL_INFO *envip, *ip;
+ int result, ret;
+
+ result = TCL_OK;
+ envip = _PtrToInfo((void *)envp);
+ if (envip == NULL) {
+ Tcl_SetResult(interp, "Could not find env info\n", TCL_STATIC);
+ return (TCL_ERROR);
+ }
+ snprintf(newname, MSG_SIZE, "%s.lock%d",
+ envip->i_name, envip->i_envlockid);
+ ip = _NewInfo(interp, NULL, newname, I_LOCK);
+ if (ip == NULL) {
+ Tcl_SetResult(interp, "Could not set up info",
+ TCL_STATIC);
+ return (TCL_ERROR);
+ }
+ ret = __os_malloc(envp, sizeof(DB_LOCK), &lock);
+ if (ret != 0) {
+ Tcl_SetResult(interp, db_strerror(ret), TCL_STATIC);
+ return (TCL_ERROR);
+ }
+ _debug_check();
+ ret = envp->lock_get(envp, lockid, flag, objp, mode, lock);
+ result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "lock get");
+ if (result == TCL_ERROR) {
+ __os_free(envp, lock);
+ _DeleteInfo(ip);
+ return (result);
+ }
+ /*
+ * Success. Set up return. Set up new info
+ * and command widget for this lock.
+ */
+ ret = __os_malloc(envp, objp->size, &ip->i_lockobj.data);
+ if (ret != 0) {
+ Tcl_SetResult(interp, "Could not duplicate obj",
+ TCL_STATIC);
+ (void)envp->lock_put(envp, lock);
+ __os_free(envp, lock);
+ _DeleteInfo(ip);
+ result = TCL_ERROR;
+ goto error;
+ }
+ memcpy(ip->i_lockobj.data, objp->data, objp->size);
+ ip->i_lockobj.size = objp->size;
+ envip->i_envlockid++;
+ ip->i_parent = envip;
+ ip->i_locker = lockid;
+ _SetInfoData(ip, lock);
+ Tcl_CreateObjCommand(interp, newname,
+ (Tcl_ObjCmdProc *)lock_Cmd, (ClientData)lock, NULL);
+error:
+ return (result);
+}
+#endif