tcl_util.c   [plain text]

/*-
 * 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 1.1.1.1 2003/02/15 04:56:14 zarzycki 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);
}