diff options
Diffstat (limited to 'db/tcl/tcl_util.c')
| -rw-r--r-- | db/tcl/tcl_util.c | 381 |
1 files changed, 381 insertions, 0 deletions
diff --git a/db/tcl/tcl_util.c b/db/tcl/tcl_util.c new file mode 100644 index 000000000..b6d46b71f --- /dev/null +++ b/db/tcl/tcl_util.c @@ -0,0 +1,381 @@ +/*- + * 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_util.c,v 11.35 2002/08/06 06:21:42 bostic Exp "; +#endif /* not lint */ + +#ifndef NO_SYSTEM_INCLUDES +#include <sys/types.h> + +#include <fcntl.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 mutex_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*)); + +/* + * bdb_RandCommand -- + * Implements rand* functions. + * + * PUBLIC: int bdb_RandCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*)); + */ +int +bdb_RandCommand(interp, objc, objv) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static char *rcmds[] = { + "rand", "random_int", "srand", + NULL + }; + enum rcmds { + RRAND, RRAND_INT, RSRAND + }; + long t; + int cmdindex, hi, lo, result, ret; + Tcl_Obj *res; + char msg[MSG_SIZE]; + + result = TCL_OK; + /* + * Get the command name index from the object based on the cmds + * defined above. This SHOULD NOT fail because we already checked + * in the 'berkdb' command. + */ + if (Tcl_GetIndexFromObj(interp, + objv[1], rcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) + return (IS_HELP(objv[1])); + + res = NULL; + switch ((enum rcmds)cmdindex) { + case RRAND: + /* + * Must be 0 args. Error if different. + */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return (TCL_ERROR); + } + ret = rand(); + res = Tcl_NewIntObj(ret); + break; + case RRAND_INT: + /* + * Must be 4 args. Error if different. + */ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "lo hi"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &lo); + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, objv[3], &hi); + if (result == TCL_OK) { +#ifndef RAND_MAX +#define RAND_MAX 0x7fffffff +#endif + t = rand(); + if (t > RAND_MAX) { + snprintf(msg, MSG_SIZE, + "Max random is higher than %ld\n", + (long)RAND_MAX); + Tcl_SetResult(interp, msg, TCL_VOLATILE); + result = TCL_ERROR; + break; + } + _debug_check(); + ret = (int)(((double)t / ((double)(RAND_MAX) + 1)) * + (hi - lo + 1)); + ret += lo; + res = Tcl_NewIntObj(ret); + } + break; + case RSRAND: + /* + * Must be 1 arg. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "seed"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &lo); + if (result == TCL_OK) { + srand((u_int)lo); + res = Tcl_NewIntObj(0); + } + break; + } + /* + * Only set result if we have a res. Otherwise, lower + * functions have already done so. + */ + if (result == TCL_OK && res) + Tcl_SetObjResult(interp, res); + return (result); +} + +/* + * + * tcl_Mutex -- + * Opens an env mutex. + * + * PUBLIC: int tcl_Mutex __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *, + * PUBLIC: DBTCL_INFO *)); + */ +int +tcl_Mutex(interp, objc, objv, envp, envip) + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ + DB_ENV *envp; /* Environment pointer */ + DBTCL_INFO *envip; /* Info pointer */ +{ + DBTCL_INFO *ip; + Tcl_Obj *res; + _MUTEX_DATA *md; + int i, mode, nitems, result, ret; + char newname[MSG_SIZE]; + + md = NULL; + result = TCL_OK; + mode = nitems = ret = 0; + memset(newname, 0, MSG_SIZE); + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "mode nitems"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &mode); + if (result != TCL_OK) + return (TCL_ERROR); + result = Tcl_GetIntFromObj(interp, objv[3], &nitems); + if (result != TCL_OK) + return (TCL_ERROR); + + snprintf(newname, sizeof(newname), + "%s.mutex%d", envip->i_name, envip->i_envmutexid); + ip = _NewInfo(interp, NULL, newname, I_MUTEX); + if (ip == NULL) { + Tcl_SetResult(interp, "Could not set up info", + TCL_STATIC); + return (TCL_ERROR); + } + /* + * Set up mutex. + */ + /* + * Map in the region. + * + * XXX + * We don't bother doing this "right", i.e., using the shalloc + * functions, just grab some memory knowing that it's correctly + * aligned. + */ + _debug_check(); + if (__os_calloc(NULL, 1, sizeof(_MUTEX_DATA), &md) != 0) + goto posixout; + md->env = envp; + md->n_mutex = nitems; + md->size = sizeof(_MUTEX_ENTRY) * nitems; + + md->reginfo.type = REGION_TYPE_MUTEX; + md->reginfo.id = INVALID_REGION_TYPE; + md->reginfo.mode = mode; + md->reginfo.flags = REGION_CREATE_OK | REGION_JOIN_OK; + if ((ret = __db_r_attach(envp, &md->reginfo, md->size)) != 0) + goto posixout; + md->marray = md->reginfo.addr; + + /* Initialize a created region. */ + if (F_ISSET(&md->reginfo, REGION_CREATE)) + for (i = 0; i < nitems; i++) { + md->marray[i].val = 0; + if ((ret = __db_mutex_init_int(envp, + &md->marray[i].m, i, 0)) != 0) + goto posixout; + } + R_UNLOCK(envp, &md->reginfo); + + /* + * Success. Set up return. Set up new info + * and command widget for this mutex. + */ + envip->i_envmutexid++; + ip->i_parent = envip; + _SetInfoData(ip, md); + Tcl_CreateObjCommand(interp, newname, + (Tcl_ObjCmdProc *)mutex_Cmd, (ClientData)md, NULL); + res = Tcl_NewStringObj(newname, strlen(newname)); + Tcl_SetObjResult(interp, res); + + return (TCL_OK); + +posixout: + if (ret > 0) + Tcl_PosixError(interp); + result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mutex"); + _DeleteInfo(ip); + + if (md != NULL) { + if (md->reginfo.addr != NULL) + (void)__db_r_detach(md->env, + &md->reginfo, F_ISSET(&md->reginfo, REGION_CREATE)); + __os_free(md->env, md); + } + return (result); +} + +/* + * mutex_Cmd -- + * Implements the "mutex" widget. + */ +static int +mutex_Cmd(clientData, interp, objc, objv) + ClientData clientData; /* Mutex handle */ + Tcl_Interp *interp; /* Interpreter */ + int objc; /* How many arguments? */ + Tcl_Obj *CONST objv[]; /* The argument objects */ +{ + static char *mxcmds[] = { + "close", + "get", + "getval", + "release", + "setval", + NULL + }; + enum mxcmds { + MXCLOSE, + MXGET, + MXGETVAL, + MXRELE, + MXSETVAL + }; + DB_ENV *dbenv; + DBTCL_INFO *envip, *mpip; + _MUTEX_DATA *mp; + Tcl_Obj *res; + int cmdindex, id, result, newval; + + Tcl_ResetResult(interp); + mp = (_MUTEX_DATA *)clientData; + mpip = _PtrToInfo((void *)mp); + envip = mpip->i_parent; + dbenv = envip->i_envp; + result = TCL_OK; + + if (mp == NULL) { + Tcl_SetResult(interp, "NULL mp pointer", TCL_STATIC); + return (TCL_ERROR); + } + if (mpip == NULL) { + Tcl_SetResult(interp, "NULL mp info pointer", TCL_STATIC); + return (TCL_ERROR); + } + + /* + * Get the command name index from the object based on the dbcmds + * defined above. + */ + if (Tcl_GetIndexFromObj(interp, + objv[1], mxcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK) + return (IS_HELP(objv[1])); + + res = NULL; + switch ((enum mxcmds)cmdindex) { + case MXCLOSE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return (TCL_ERROR); + } + _debug_check(); + (void)__db_r_detach(mp->env, &mp->reginfo, 0); + res = Tcl_NewIntObj(0); + (void)Tcl_DeleteCommand(interp, mpip->i_name); + _DeleteInfo(mpip); + __os_free(mp->env, mp); + break; + case MXRELE: + /* + * Check for 1 arg. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &id); + if (result != TCL_OK) + break; + MUTEX_UNLOCK(dbenv, &mp->marray[id].m); + res = Tcl_NewIntObj(0); + break; + case MXGET: + /* + * Check for 1 arg. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &id); + if (result != TCL_OK) + break; + MUTEX_LOCK(dbenv, &mp->marray[id].m); + res = Tcl_NewIntObj(0); + break; + case MXGETVAL: + /* + * Check for 1 arg. Error if different. + */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "id"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &id); + if (result != TCL_OK) + break; + res = Tcl_NewLongObj((long)mp->marray[id].val); + break; + case MXSETVAL: + /* + * Check for 2 args. Error if different. + */ + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "id val"); + return (TCL_ERROR); + } + result = Tcl_GetIntFromObj(interp, objv[2], &id); + if (result != TCL_OK) + break; + result = Tcl_GetIntFromObj(interp, objv[3], &newval); + if (result != TCL_OK) + break; + mp->marray[id].val = newval; + res = Tcl_NewIntObj(0); + break; + } + /* + * Only set result if we have a res. Otherwise, lower + * functions have already done so. + */ + if (result == TCL_OK && res) + Tcl_SetObjResult(interp, res); + return (result); +} |