/*-
* See the file LICENSE for redistribution information.
*
* Copyright (c) 1999, 2000
* Sleepycat Software. All rights reserved.
*/
#include "db_config.h"
#ifndef lint
static const char revid[] = "$Id: tcl_env.c,v 11.33 2001/01/11 18:19:55 bostic Exp $";
#endif /* not lint */
#ifndef NO_SYSTEM_INCLUDES
#include <sys/types.h>
#include <stdlib.h>
#include <tcl.h>
#endif
#include "db_int.h"
#include "tcl_db.h"
/*
* Prototypes for procedures defined later in this file:
*/
static void _EnvInfoDelete __P((Tcl_Interp *, DBTCL_INFO *));
/*
* PUBLIC: int env_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
*
* env_Cmd --
* Implements the "env" command.
*/
int
env_Cmd(clientData, interp, objc, objv)
ClientData clientData; /* Env handle */
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
{
static char *envcmds[] = {
"close",
"lock_detect",
"lock_id",
"lock_get",
"lock_stat",
"lock_vec",
"log_archive",
"log_compare",
"log_file",
"log_flush",
"log_get",
"log_put",
"log_register",
"log_stat",
"log_unregister",
"mpool",
"mpool_stat",
"mpool_sync",
"mpool_trickle",
"mutex",
#if CONFIG_TEST
"test",
#endif
"txn",
"txn_checkpoint",
"txn_stat",
"verbose",
NULL
};
enum envcmds {
ENVCLOSE,
ENVLKDETECT,
ENVLKID,
ENVLKGET,
ENVLKSTAT,
ENVLKVEC,
ENVLOGARCH,
ENVLOGCMP,
ENVLOGFILE,
ENVLOGFLUSH,
ENVLOGGET,
ENVLOGPUT,
ENVLOGREG,
ENVLOGSTAT,
ENVLOGUNREG,
ENVMP,
ENVMPSTAT,
ENVMPSYNC,
ENVTRICKLE,
ENVMUTEX,
#if CONFIG_TEST
ENVTEST,
#endif
ENVTXN,
ENVTXNCKP,
ENVTXNSTAT,
ENVVERB
};
DBTCL_INFO *envip;
DB_ENV *envp;
Tcl_Obj *res;
u_int32_t newval;
int cmdindex, result, ret;
Tcl_ResetResult(interp);
envp = (DB_ENV *)clientData;
envip = _PtrToInfo((void *)envp);
result = TCL_OK;
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
return (TCL_ERROR);
}
if (envp == NULL) {
Tcl_SetResult(interp, "NULL env pointer", TCL_STATIC);
return (TCL_ERROR);
}
if (envip == NULL) {
Tcl_SetResult(interp, "NULL env info pointer", TCL_STATIC);
return (TCL_ERROR);
}
/*
* Get the command name index from the object based on the berkdbcmds
* defined above.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], envcmds, "command",
TCL_EXACT, &cmdindex) != TCL_OK)
return (IS_HELP(objv[1]));
res = NULL;
switch ((enum envcmds)cmdindex) {
case ENVCLOSE:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
/*
* Any transactions will be aborted, and an mpools
* closed automatically. We must delete any txn
* and mp widgets we have here too for this env.
* NOTE: envip is freed when we come back from
* this function. Set it to NULL to make sure no
* one tries to use it later.
*/
_EnvInfoDelete(interp, envip);
envip = NULL;
_debug_check();
ret = envp->close(envp, 0);
result = _ReturnSetup(interp, ret, "env close");
break;
case ENVLKDETECT:
result = tcl_LockDetect(interp, objc, objv, envp);
break;
case ENVLKSTAT:
result = tcl_LockStat(interp, objc, objv, envp);
break;
case ENVLKID:
/*
* No args for this. Error if there are some.
*/
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
_debug_check();
ret = lock_id(envp, &newval);
result = _ReturnSetup(interp, ret, "lock_id");
if (result == TCL_OK)
res = Tcl_NewIntObj((int)newval);
break;
case ENVLKGET:
result = tcl_LockGet(interp, objc, objv, envp);
break;
case ENVLKVEC:
result = tcl_LockVec(interp, objc, objv, envp);
break;
case ENVLOGARCH:
result = tcl_LogArchive(interp, objc, objv, envp);
break;
case ENVLOGCMP:
result = tcl_LogCompare(interp, objc, objv);
break;
case ENVLOGFILE:
result = tcl_LogFile(interp, objc, objv, envp);
break;
case ENVLOGFLUSH:
result = tcl_LogFlush(interp, objc, objv, envp);
break;
case ENVLOGGET:
result = tcl_LogGet(interp, objc, objv, envp);
break;
case ENVLOGPUT:
result = tcl_LogPut(interp, objc, objv, envp);
break;
case ENVLOGREG:
result = tcl_LogRegister(interp, objc, objv, envp);
break;
case ENVLOGUNREG:
result = tcl_LogUnregister(interp, objc, objv, envp);
break;
case ENVLOGSTAT:
result = tcl_LogStat(interp, objc, objv, envp);
break;
case ENVMPSTAT:
result = tcl_MpStat(interp, objc, objv, envp);
break;
case ENVMPSYNC:
result = tcl_MpSync(interp, objc, objv, envp);
break;
case ENVTRICKLE:
result = tcl_MpTrickle(interp, objc, objv, envp);
break;
case ENVMP:
result = tcl_Mp(interp, objc, objv, envp, envip);
break;
case ENVTXNCKP:
result = tcl_TxnCheckpoint(interp, objc, objv, envp);
break;
case ENVTXNSTAT:
result = tcl_TxnStat(interp, objc, objv, envp);
break;
case ENVTXN:
result = tcl_Txn(interp, objc, objv, envp, envip);
break;
case ENVMUTEX:
result = tcl_Mutex(interp, objc, objv, envp, envip);
break;
#if CONFIG_TEST
case ENVTEST:
result = tcl_EnvTest(interp, objc, objv, envp);
break;
#endif
case ENVVERB:
/*
* Two args for this. Error if different.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return (TCL_ERROR);
}
result = tcl_EnvVerbose(interp, envp, objv[2], objv[3]);
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);
}
/*
* PUBLIC: int tcl_EnvRemove __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
* PUBLIC: DB_ENV *, DBTCL_INFO *));
*
* tcl_EnvRemove --
*/
int
tcl_EnvRemove(interp, objc, objv, envp, envip)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *envp; /* Env pointer */
DBTCL_INFO *envip; /* Info pointer */
{
static char *envremopts[] = {
"-data_dir",
"-force",
"-home",
"-log_dir",
"-server",
"-tmp_dir",
"-use_environ",
"-use_environ_root",
NULL
};
enum envremopts {
ENVREM_DATADIR,
ENVREM_FORCE,
ENVREM_HOME,
ENVREM_LOGDIR,
ENVREM_SERVER,
ENVREM_TMPDIR,
ENVREM_USE_ENVIRON,
ENVREM_USE_ENVIRON_ROOT
};
DB_ENV *e;
u_int32_t cflag, flag, forceflag;
int i, optindex, result, ret;
char *datadir, *home, *logdir, *server, *tmpdir;
result = TCL_OK;
cflag = flag = forceflag = 0;
home = NULL;
datadir = logdir = tmpdir = NULL;
server = NULL;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?args?");
return (TCL_ERROR);
}
i = 2;
while (i < objc) {
if (Tcl_GetIndexFromObj(interp, objv[i], envremopts, "option",
TCL_EXACT, &optindex) != TCL_OK) {
result = IS_HELP(objv[i]);
goto error;
}
i++;
switch ((enum envremopts)optindex) {
case ENVREM_FORCE:
forceflag |= DB_FORCE;
break;
case ENVREM_HOME:
/* Make sure we have an arg to check against! */
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-home dir?");
result = TCL_ERROR;
break;
}
home = Tcl_GetStringFromObj(objv[i++], NULL);
break;
case ENVREM_SERVER:
/* Make sure we have an arg to check against! */
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-server name?");
result = TCL_ERROR;
break;
}
server = Tcl_GetStringFromObj(objv[i++], NULL);
cflag = DB_CLIENT;
break;
case ENVREM_USE_ENVIRON:
flag |= DB_USE_ENVIRON;
break;
case ENVREM_USE_ENVIRON_ROOT:
flag |= DB_USE_ENVIRON_ROOT;
break;
case ENVREM_DATADIR:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"-data_dir dir");
result = TCL_ERROR;
break;
}
datadir = Tcl_GetStringFromObj(objv[i++], NULL);
break;
case ENVREM_LOGDIR:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"-log_dir dir");
result = TCL_ERROR;
break;
}
logdir = Tcl_GetStringFromObj(objv[i++], NULL);
break;
case ENVREM_TMPDIR:
if (i >= objc) {
Tcl_WrongNumArgs(interp, 2, objv,
"-tmp_dir dir");
result = TCL_ERROR;
break;
}
tmpdir = Tcl_GetStringFromObj(objv[i++], NULL);
break;
}
/*
* If, at any time, parsing the args we get an error,
* bail out and return.
*/
if (result != TCL_OK)
goto error;
}
/*
* If envp is NULL, we don't have an open env and we need to open
* one of the user. Don't bother with the info stuff.
*/
if (envp == NULL) {
if ((ret = db_env_create(&e, cflag)) != 0) {
result = _ReturnSetup(interp, ret, "db_env_create");
goto error;
}
if (server != NULL) {
ret = e->set_server(e, server, 0, 0, 0);
result = _ReturnSetup(interp, ret, "set_server");
if (result != TCL_OK)
goto error;
}
if (datadir != NULL) {
_debug_check();
ret = e->set_data_dir(e, datadir);
result = _ReturnSetup(interp, ret, "set_data_dir");
if (result != TCL_OK)
goto error;
}
if (logdir != NULL) {
_debug_check();
ret = e->set_lg_dir(e, logdir);
result = _ReturnSetup(interp, ret, "set_log_dir");
if (result != TCL_OK)
goto error;
}
if (tmpdir != NULL) {
_debug_check();
ret = e->set_tmp_dir(e, tmpdir);
result = _ReturnSetup(interp, ret, "set_tmp_dir");
if (result != TCL_OK)
goto error;
}
} else {
/*
* We have to clean up any info associated with this env,
* regardless of the result of the remove so do it first.
* NOTE: envip is freed when we come back from this function.
*/
_EnvInfoDelete(interp, envip);
envip = NULL;
e = envp;
}
flag |= forceflag;
/*
* When we get here we have parsed all the args. Now remove
* the environment.
*/
_debug_check();
ret = e->remove(e, home, flag);
result = _ReturnSetup(interp, ret, "env remove");
error:
return (result);
}
static void
_EnvInfoDelete(interp, envip)
Tcl_Interp *interp; /* Tcl Interpreter */
DBTCL_INFO *envip; /* Info for env */
{
DBTCL_INFO *nextp, *p;
/*
* Before we can delete the environment info, we must close
* any open subsystems in this env. We will:
* 1. Abort any transactions (which aborts any nested txns).
* 2. Close any mpools (which will put any pages itself).
* 3. Put any locks.
* 4. Close the error file.
*/
for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
/*
* Check if this info structure "belongs" to this
* env. If so, remove its commands and info structure.
* We do not close/abort/whatever here, because we
* don't want to replicate DB behavior.
*/
if (p->i_parent == envip) {
switch (p->i_type) {
case I_TXN:
_TxnInfoDelete(interp, p);
break;
case I_MP:
_MpInfoDelete(interp, p);
break;
default:
Tcl_SetResult(interp,
"_EnvInfoDelete: bad info type",
TCL_STATIC);
break;
}
nextp = LIST_NEXT(p, entries);
(void)Tcl_DeleteCommand(interp, p->i_name);
_DeleteInfo(p);
} else
nextp = LIST_NEXT(p, entries);
}
(void)Tcl_DeleteCommand(interp, envip->i_name);
_DeleteInfo(envip);
}
/*
* PUBLIC: int tcl_EnvVerbose __P((Tcl_Interp *, DB_ENV *, Tcl_Obj *,
* PUBLIC: Tcl_Obj *));
*
* tcl_EnvVerbose --
*/
int
tcl_EnvVerbose(interp, envp, which, onoff)
Tcl_Interp *interp; /* Interpreter */
DB_ENV *envp; /* Env pointer */
Tcl_Obj *which; /* Which subsystem */
Tcl_Obj *onoff; /* On or off */
{
static char *verbwhich[] = {
"chkpt",
"deadlock",
"recovery",
"wait",
NULL
};
enum verbwhich {
ENVVERB_CHK,
ENVVERB_DEAD,
ENVVERB_REC,
ENVVERB_WAIT
};
static char *verbonoff[] = {
"off",
"on",
NULL
};
enum verbonoff {
ENVVERB_OFF,
ENVVERB_ON
};
int on, optindex, ret;
u_int32_t wh;
if (Tcl_GetIndexFromObj(interp, which, verbwhich, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(which));
switch ((enum verbwhich)optindex) {
case ENVVERB_CHK:
wh = DB_VERB_CHKPOINT;
break;
case ENVVERB_DEAD:
wh = DB_VERB_DEADLOCK;
break;
case ENVVERB_REC:
wh = DB_VERB_RECOVERY;
break;
case ENVVERB_WAIT:
wh = DB_VERB_WAITSFOR;
break;
default:
return (TCL_ERROR);
}
if (Tcl_GetIndexFromObj(interp, onoff, verbonoff, "option",
TCL_EXACT, &optindex) != TCL_OK)
return (IS_HELP(onoff));
switch ((enum verbonoff)optindex) {
case ENVVERB_OFF:
on = 0;
break;
case ENVVERB_ON:
on = 1;
break;
default:
return (TCL_ERROR);
}
ret = envp->set_verbose(envp, wh, on);
return (_ReturnSetup(interp, ret, "env set verbose"));
}
#if CONFIG_TEST
/*
* PUBLIC: int tcl_EnvTest __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
*
* tcl_EnvTest --
*/
int
tcl_EnvTest(interp, objc, objv, envp)
Tcl_Interp *interp; /* Interpreter */
int objc; /* How many arguments? */
Tcl_Obj *CONST objv[]; /* The argument objects */
DB_ENV *envp; /* Env pointer */
{
static char *envtestcmd[] = {
"abort",
"copy",
NULL
};
enum envtestcmd {
ENVTEST_ABORT,
ENVTEST_COPY
};
static char *envtestat[] = {
"none",
"preopen",
"prerename",
"postlog",
"postlogmeta",
"postopen",
"postrename",
"postsync",
NULL
};
enum envtestat {
ENVTEST_NONE,
ENVTEST_PREOPEN,
ENVTEST_PRERENAME,
ENVTEST_POSTLOG,
ENVTEST_POSTLOGMETA,
ENVTEST_POSTOPEN,
ENVTEST_POSTRENAME,
ENVTEST_POSTSYNC
};
int *loc, optindex, result, testval;
result = TCL_OK;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "abort|copy location");
return (TCL_ERROR);
}
/*
* This must be the "copy" or "abort" portion of the command.
*/
if (Tcl_GetIndexFromObj(interp, objv[2], envtestcmd, "command",
TCL_EXACT, &optindex) != TCL_OK) {
result = IS_HELP(objv[2]);
return (result);
}
switch ((enum envtestcmd)optindex) {
case ENVTEST_ABORT:
loc = &envp->test_abort;
break;
case ENVTEST_COPY:
loc = &envp->test_copy;
break;
default:
Tcl_SetResult(interp, "Illegal store location", TCL_STATIC);
return (TCL_ERROR);
}
/*
* This must be the location portion of the command.
*/
if (Tcl_GetIndexFromObj(interp, objv[3], envtestat, "location",
TCL_EXACT, &optindex) != TCL_OK) {
result = IS_HELP(objv[3]);
return (result);
}
switch ((enum envtestat)optindex) {
case ENVTEST_NONE:
testval = 0;
break;
case ENVTEST_PREOPEN:
testval = DB_TEST_PREOPEN;
break;
case ENVTEST_PRERENAME:
testval = DB_TEST_PRERENAME;
break;
case ENVTEST_POSTLOG:
testval = DB_TEST_POSTLOG;
break;
case ENVTEST_POSTLOGMETA:
testval = DB_TEST_POSTLOGMETA;
break;
case ENVTEST_POSTOPEN:
testval = DB_TEST_POSTOPEN;
break;
case ENVTEST_POSTRENAME:
testval = DB_TEST_POSTRENAME;
break;
case ENVTEST_POSTSYNC:
testval = DB_TEST_POSTSYNC;
break;
default:
Tcl_SetResult(interp, "Illegal test location", TCL_STATIC);
return (TCL_ERROR);
}
*loc = testval;
Tcl_SetResult(interp, "0", TCL_STATIC);
return (result);
}
#endif