diff options
Diffstat (limited to 'db/tcl/tcl_env.c')
| -rw-r--r-- | db/tcl/tcl_env.c | 678 |
1 files changed, 678 insertions, 0 deletions
diff --git a/db/tcl/tcl_env.c b/db/tcl/tcl_env.c new file mode 100644 index 000000000..cb7b0d974 --- /dev/null +++ b/db/tcl/tcl_env.c @@ -0,0 +1,678 @@ +/*- + * 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 |