summaryrefslogtreecommitdiff
path: root/tcl/tcl_mp.c
diff options
context:
space:
mode:
Diffstat (limited to 'tcl/tcl_mp.c')
-rw-r--r--tcl/tcl_mp.c939
1 files changed, 0 insertions, 939 deletions
diff --git a/tcl/tcl_mp.c b/tcl/tcl_mp.c
deleted file mode 100644
index 5c6488f..0000000
--- a/tcl/tcl_mp.c
+++ /dev/null
@@ -1,939 +0,0 @@
-/*-
- * See the file LICENSE for redistribution information.
- *
- * Copyright (c) 1999-2009 Oracle. All rights reserved.
- *
- * $Id$
- */
-
-#include "db_config.h"
-
-#include "db_int.h"
-#ifdef HAVE_SYSTEM_INCLUDE_FILES
-#include <tcl.h>
-#endif
-#include "dbinc/tcl_db.h"
-
-/*
- * Prototypes for procedures defined later in this file:
- */
-#ifdef CONFIG_TEST
-static int mp_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
-static int pg_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
-static int tcl_MpGet __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
- DB_MPOOLFILE *, DBTCL_INFO *));
-static int tcl_Pg __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
- void *, DB_MPOOLFILE *, DBTCL_INFO *));
-static int tcl_PgInit __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
- void *, DBTCL_INFO *));
-static int tcl_PgIsset __P((Tcl_Interp *, int, Tcl_Obj * CONST*,
- void *, DBTCL_INFO *));
-#endif
-
-/*
- * _MpInfoDelete --
- * Removes "sub" mp page info structures that are children
- * of this mp.
- *
- * PUBLIC: void _MpInfoDelete __P((Tcl_Interp *, DBTCL_INFO *));
- */
-void
-_MpInfoDelete(interp, mpip)
- Tcl_Interp *interp; /* Interpreter */
- DBTCL_INFO *mpip; /* Info for mp */
-{
- DBTCL_INFO *nextp, *p;
-
- for (p = LIST_FIRST(&__db_infohead); p != NULL; p = nextp) {
- /*
- * Check if this info structure "belongs" to this
- * mp. Remove its commands and info structure.
- */
- nextp = LIST_NEXT(p, entries);
- if (p->i_parent == mpip && p->i_type == I_PG) {
- (void)Tcl_DeleteCommand(interp, p->i_name);
- _DeleteInfo(p);
- }
- }
-}
-
-#ifdef CONFIG_TEST
-/*
- * tcl_MpSync --
- *
- * PUBLIC: int tcl_MpSync __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
- */
-int
-tcl_MpSync(interp, objc, objv, dbenv)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- DB_ENV *dbenv; /* Environment pointer */
-{
-
- DB_LSN lsn, *lsnp;
- int result, ret;
-
- result = TCL_OK;
- lsnp = NULL;
- /*
- * No flags, must be 3 args.
- */
- if (objc == 3) {
- result = _GetLsn(interp, objv[2], &lsn);
- if (result == TCL_ERROR)
- return (result);
- lsnp = &lsn;
- }
- else if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, "lsn");
- return (TCL_ERROR);
- }
-
- _debug_check();
- ret = dbenv->memp_sync(dbenv, lsnp);
- return (_ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp sync"));
-}
-
-/*
- * tcl_MpTrickle --
- *
- * PUBLIC: int tcl_MpTrickle __P((Tcl_Interp *, int,
- * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
- */
-int
-tcl_MpTrickle(interp, objc, objv, dbenv)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- DB_ENV *dbenv; /* Environment pointer */
-{
-
- Tcl_Obj *res;
- int pages, percent, result, ret;
-
- result = TCL_OK;
- /*
- * No flags, must be 3 args.
- */
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "percent");
- return (TCL_ERROR);
- }
-
- result = Tcl_GetIntFromObj(interp, objv[2], &percent);
- if (result == TCL_ERROR)
- return (result);
-
- _debug_check();
- ret = dbenv->memp_trickle(dbenv, percent, &pages);
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp trickle");
- if (result == TCL_ERROR)
- return (result);
-
- res = Tcl_NewIntObj(pages);
- Tcl_SetObjResult(interp, res);
- return (result);
-
-}
-
-/*
- * tcl_Mp --
- *
- * PUBLIC: int tcl_Mp __P((Tcl_Interp *, int,
- * PUBLIC: Tcl_Obj * CONST*, DB_ENV *, DBTCL_INFO *));
- */
-int
-tcl_Mp(interp, objc, objv, dbenv, envip)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- DB_ENV *dbenv; /* Environment pointer */
- DBTCL_INFO *envip; /* Info pointer */
-{
- static const char *mpopts[] = {
- "-create",
- "-mode",
- "-multiversion",
- "-nommap",
- "-pagesize",
- "-rdonly",
- NULL
- };
- enum mpopts {
- MPCREATE,
- MPMODE,
- MPMULTIVERSION,
- MPNOMMAP,
- MPPAGE,
- MPRDONLY
- };
- DBTCL_INFO *ip;
- DB_MPOOLFILE *mpf;
- Tcl_Obj *res;
- u_int32_t flag;
- int i, pgsize, mode, optindex, result, ret;
- char *file, newname[MSG_SIZE];
-
- result = TCL_OK;
- i = 2;
- flag = 0;
- mode = 0;
- pgsize = 0;
- memset(newname, 0, MSG_SIZE);
- while (i < objc) {
- if (Tcl_GetIndexFromObj(interp, objv[i],
- mpopts, "option", TCL_EXACT, &optindex) != TCL_OK) {
- /*
- * Reset the result so we don't get an errant
- * error message if there is another error.
- * This arg is the file name.
- */
- if (IS_HELP(objv[i]) == TCL_OK)
- return (TCL_OK);
- Tcl_ResetResult(interp);
- break;
- }
- i++;
- switch ((enum mpopts)optindex) {
- case MPCREATE:
- flag |= DB_CREATE;
- break;
- case MPMODE:
- if (i >= objc) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-mode mode?");
- result = TCL_ERROR;
- break;
- }
- /*
- * Don't need to check result here because
- * if TCL_ERROR, the error message is already
- * set up, and we'll bail out below. If ok,
- * the mode is set and we go on.
- */
- result = Tcl_GetIntFromObj(interp, objv[i++], &mode);
- break;
- case MPMULTIVERSION:
- flag |= DB_MULTIVERSION;
- break;
- case MPNOMMAP:
- flag |= DB_NOMMAP;
- break;
- case MPPAGE:
- if (i >= objc) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "?-pagesize size?");
- result = TCL_ERROR;
- break;
- }
- /*
- * Don't need to check result here because
- * if TCL_ERROR, the error message is already
- * set up, and we'll bail out below. If ok,
- * the mode is set and we go on.
- */
- result = Tcl_GetIntFromObj(interp, objv[i++], &pgsize);
- break;
- case MPRDONLY:
- flag |= DB_RDONLY;
- break;
- }
- if (result != TCL_OK)
- goto error;
- }
- /*
- * Any left over arg is a file name. It better be the last arg.
- */
- file = NULL;
- if (i != objc) {
- if (i != objc - 1) {
- Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
- result = TCL_ERROR;
- goto error;
- }
- file = Tcl_GetStringFromObj(objv[i++], NULL);
- }
-
- snprintf(newname, sizeof(newname), "%s.mp%d",
- envip->i_name, envip->i_envmpid);
- ip = _NewInfo(interp, NULL, newname, I_MP);
- if (ip == NULL) {
- Tcl_SetResult(interp, "Could not set up info",
- TCL_STATIC);
- return (TCL_ERROR);
- }
-
- _debug_check();
- if ((ret = dbenv->memp_fcreate(dbenv, &mpf, 0)) != 0) {
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mpool");
- _DeleteInfo(ip);
- goto error;
- }
-
- /*
- * XXX
- * Interface doesn't currently support DB_MPOOLFILE configuration.
- */
- if ((ret = mpf->open(mpf, file, flag, mode, (size_t)pgsize)) != 0) {
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "mpool");
- _DeleteInfo(ip);
-
- (void)mpf->close(mpf, 0);
- goto error;
- }
-
- /*
- * Success. Set up return. Set up new info and command widget for
- * this mpool.
- */
- envip->i_envmpid++;
- ip->i_parent = envip;
- ip->i_pgsz = pgsize;
- _SetInfoData(ip, mpf);
- (void)Tcl_CreateObjCommand(interp, newname,
- (Tcl_ObjCmdProc *)mp_Cmd, (ClientData)mpf, NULL);
- res = NewStringObj(newname, strlen(newname));
- Tcl_SetObjResult(interp, res);
-
-error:
- return (result);
-}
-
-/*
- * tcl_MpStat --
- *
- * PUBLIC: int tcl_MpStat __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
- */
-int
-tcl_MpStat(interp, objc, objv, dbenv)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- DB_ENV *dbenv; /* Environment pointer */
-{
- DB_MPOOL_FSTAT **fsp, **savefsp;
- DB_MPOOL_STAT *sp;
- int result;
- int ret;
- Tcl_Obj *res;
- Tcl_Obj *res1;
-
- result = TCL_OK;
- savefsp = NULL;
- /*
- * No args for this. Error if there are some.
- */
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- return (TCL_ERROR);
- }
- _debug_check();
- ret = dbenv->memp_stat(dbenv, &sp, &fsp, 0);
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "memp 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();
-#ifdef HAVE_STATISTICS
- /*
- * MAKE_STAT_LIST assumes 'res' and 'error' label.
- */
- MAKE_STAT_LIST("Cache size (gbytes)", sp->st_gbytes);
- MAKE_STAT_LIST("Cache size (bytes)", sp->st_bytes);
- MAKE_STAT_LIST("Number of caches", sp->st_ncache);
- MAKE_STAT_LIST("Maximum number of caches", sp->st_max_ncache);
- MAKE_STAT_LIST("Region size", sp->st_regsize);
- MAKE_STAT_LIST("Maximum memory-mapped file size", sp->st_mmapsize);
- MAKE_STAT_LIST("Maximum open file descriptors", sp->st_maxopenfd);
- MAKE_STAT_LIST("Maximum sequential buffer writes", sp->st_maxwrite);
- MAKE_STAT_LIST(
- "Sleep after writing maximum buffers", sp->st_maxwrite_sleep);
- MAKE_STAT_LIST("Pages mapped into address space", sp->st_map);
- MAKE_WSTAT_LIST("Cache hits", sp->st_cache_hit);
- MAKE_WSTAT_LIST("Cache misses", sp->st_cache_miss);
- MAKE_WSTAT_LIST("Pages created", sp->st_page_create);
- MAKE_WSTAT_LIST("Pages read in", sp->st_page_in);
- MAKE_WSTAT_LIST("Pages written", sp->st_page_out);
- MAKE_WSTAT_LIST("Clean page evictions", sp->st_ro_evict);
- MAKE_WSTAT_LIST("Dirty page evictions", sp->st_rw_evict);
- MAKE_WSTAT_LIST("Dirty pages trickled", sp->st_page_trickle);
- MAKE_STAT_LIST("Cached pages", sp->st_pages);
- MAKE_WSTAT_LIST("Cached clean pages", sp->st_page_clean);
- MAKE_WSTAT_LIST("Cached dirty pages", sp->st_page_dirty);
- MAKE_WSTAT_LIST("Hash buckets", sp->st_hash_buckets);
- MAKE_WSTAT_LIST("Default pagesize", sp->st_pagesize);
- MAKE_WSTAT_LIST("Hash lookups", sp->st_hash_searches);
- MAKE_WSTAT_LIST("Longest hash chain found", sp->st_hash_longest);
- MAKE_WSTAT_LIST("Hash elements examined", sp->st_hash_examined);
- MAKE_WSTAT_LIST("Number of hash bucket nowaits", sp->st_hash_nowait);
- MAKE_WSTAT_LIST("Number of hash bucket waits", sp->st_hash_wait);
- MAKE_STAT_LIST("Maximum number of hash bucket nowaits",
- sp->st_hash_max_nowait);
- MAKE_STAT_LIST("Maximum number of hash bucket waits",
- sp->st_hash_max_wait);
- MAKE_WSTAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
- MAKE_WSTAT_LIST("Number of region lock waits", sp->st_region_wait);
- MAKE_WSTAT_LIST("Buffers frozen", sp->st_mvcc_frozen);
- MAKE_WSTAT_LIST("Buffers thawed", sp->st_mvcc_thawed);
- MAKE_WSTAT_LIST("Frozen buffers freed", sp->st_mvcc_freed);
- MAKE_WSTAT_LIST("Page allocations", sp->st_alloc);
- MAKE_STAT_LIST("Buckets examined during allocation",
- sp->st_alloc_buckets);
- MAKE_STAT_LIST("Maximum buckets examined during allocation",
- sp->st_alloc_max_buckets);
- MAKE_WSTAT_LIST("Pages examined during allocation", sp->st_alloc_pages);
- MAKE_STAT_LIST("Maximum pages examined during allocation",
- sp->st_alloc_max_pages);
- MAKE_WSTAT_LIST("Threads waiting on buffer I/O", sp->st_io_wait);
- MAKE_WSTAT_LIST("Number of syncs interrupted", sp->st_sync_interrupted);
-
- /*
- * Save global stat list as res1. The MAKE_STAT_LIST
- * macro assumes 'res' so we'll use that to build up
- * our per-file sublist.
- */
- res1 = res;
- for (savefsp = fsp; fsp != NULL && *fsp != NULL; fsp++) {
- res = Tcl_NewObj();
- MAKE_STAT_STRLIST("File Name", (*fsp)->file_name);
- MAKE_STAT_LIST("Page size", (*fsp)->st_pagesize);
- MAKE_STAT_LIST("Pages mapped into address space",
- (*fsp)->st_map);
- MAKE_WSTAT_LIST("Cache hits", (*fsp)->st_cache_hit);
- MAKE_WSTAT_LIST("Cache misses", (*fsp)->st_cache_miss);
- MAKE_WSTAT_LIST("Pages created", (*fsp)->st_page_create);
- MAKE_WSTAT_LIST("Pages read in", (*fsp)->st_page_in);
- MAKE_WSTAT_LIST("Pages written", (*fsp)->st_page_out);
- /*
- * Now that we have a complete "per-file" stat list, append
- * that to the other list.
- */
- result = Tcl_ListObjAppendElement(interp, res1, res);
- if (result != TCL_OK)
- goto error;
- }
-#endif
- Tcl_SetObjResult(interp, res1);
-error:
- __os_ufree(dbenv->env, sp);
- if (savefsp != NULL)
- __os_ufree(dbenv->env, savefsp);
- return (result);
-}
-
-/*
- * mp_Cmd --
- * Implements the "mp" widget.
- */
-static int
-mp_Cmd(clientData, interp, objc, objv)
- ClientData clientData; /* Mp handle */
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
-{
- static const char *mpcmds[] = {
- "close",
- "fsync",
- "get",
- "get_clear_len",
- "get_fileid",
- "get_ftype",
- "get_lsn_offset",
- "get_pgcookie",
- NULL
- };
- enum mpcmds {
- MPCLOSE,
- MPFSYNC,
- MPGET,
- MPGETCLEARLEN,
- MPGETFILEID,
- MPGETFTYPE,
- MPGETLSNOFFSET,
- MPGETPGCOOKIE
- };
- DB_MPOOLFILE *mp;
- int cmdindex, ftype, length, result, ret;
- DBTCL_INFO *mpip;
- Tcl_Obj *res;
- char *obj_name;
- u_int32_t value;
- int32_t intval;
- u_int8_t fileid[DB_FILE_ID_LEN];
- DBT cookie;
-
- Tcl_ResetResult(interp);
- mp = (DB_MPOOLFILE *)clientData;
- obj_name = Tcl_GetStringFromObj(objv[0], &length);
- mpip = _NameToInfo(obj_name);
- 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], mpcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
- return (IS_HELP(objv[1]));
-
- res = NULL;
- switch ((enum mpcmds)cmdindex) {
- case MPCLOSE:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- _debug_check();
- ret = mp->close(mp, 0);
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp close");
- _MpInfoDelete(interp, mpip);
- (void)Tcl_DeleteCommand(interp, mpip->i_name);
- _DeleteInfo(mpip);
- break;
- case MPFSYNC:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- _debug_check();
- ret = mp->sync(mp);
- res = Tcl_NewIntObj(ret);
- break;
- case MPGET:
- result = tcl_MpGet(interp, objc, objv, mp, mpip);
- break;
- case MPGETCLEARLEN:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- ret = mp->get_clear_len(mp, &value);
- if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp get_clear_len")) == TCL_OK)
- res = Tcl_NewIntObj((int)value);
- break;
- case MPGETFILEID:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- ret = mp->get_fileid(mp, fileid);
- if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp get_fileid")) == TCL_OK)
- res = NewStringObj((char *)fileid, DB_FILE_ID_LEN);
- break;
- case MPGETFTYPE:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- ret = mp->get_ftype(mp, &ftype);
- if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp get_ftype")) == TCL_OK)
- res = Tcl_NewIntObj(ftype);
- break;
- case MPGETLSNOFFSET:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- ret = mp->get_lsn_offset(mp, &intval);
- if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp get_lsn_offset")) == TCL_OK)
- res = Tcl_NewIntObj(intval);
- break;
- case MPGETPGCOOKIE:
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, NULL);
- return (TCL_ERROR);
- }
- memset(&cookie, 0, sizeof(DBT));
- ret = mp->get_pgcookie(mp, &cookie);
- if ((result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
- "mp get_pgcookie")) == TCL_OK)
- res = Tcl_NewByteArrayObj((u_char *)cookie.data,
- (int)cookie.size);
- 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_MpGet --
- */
-static int
-tcl_MpGet(interp, objc, objv, mp, mpip)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- DB_MPOOLFILE *mp; /* mp pointer */
- DBTCL_INFO *mpip; /* mp info pointer */
-{
- static const char *mpget[] = {
- "-create",
- "-dirty",
- "-last",
- "-new",
- "-txn",
- NULL
- };
- enum mpget {
- MPGET_CREATE,
- MPGET_DIRTY,
- MPGET_LAST,
- MPGET_NEW,
- MPGET_TXN
- };
-
- DBTCL_INFO *ip;
- Tcl_Obj *res;
- DB_TXN *txn;
- db_pgno_t pgno;
- u_int32_t flag;
- int i, ipgno, optindex, result, ret;
- char *arg, msg[MSG_SIZE], newname[MSG_SIZE];
- void *page;
-
- txn = NULL;
- result = TCL_OK;
- memset(newname, 0, MSG_SIZE);
- i = 2;
- flag = 0;
- while (i < objc) {
- if (Tcl_GetIndexFromObj(interp, objv[i],
- mpget, "option", TCL_EXACT, &optindex) != TCL_OK) {
- /*
- * Reset the result so we don't get an errant
- * error message if there is another error.
- * This arg is the page number.
- */
- if (IS_HELP(objv[i]) == TCL_OK)
- return (TCL_OK);
- Tcl_ResetResult(interp);
- break;
- }
- i++;
- switch ((enum mpget)optindex) {
- case MPGET_CREATE:
- flag |= DB_MPOOL_CREATE;
- break;
- case MPGET_DIRTY:
- flag |= DB_MPOOL_DIRTY;
- break;
- case MPGET_LAST:
- flag |= DB_MPOOL_LAST;
- break;
- case MPGET_NEW:
- flag |= DB_MPOOL_NEW;
- break;
- case MPGET_TXN:
- if (i == objc) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-txn id?");
- result = TCL_ERROR;
- break;
- }
- arg = Tcl_GetStringFromObj(objv[i++], NULL);
- txn = NAME_TO_TXN(arg);
- if (txn == NULL) {
- snprintf(msg, MSG_SIZE,
- "mpool get: Invalid txn: %s\n", arg);
- Tcl_SetResult(interp, msg, TCL_VOLATILE);
- result = TCL_ERROR;
- }
- break;
- }
- if (result != TCL_OK)
- goto error;
- }
- /*
- * Any left over arg is a page number. It better be the last arg.
- */
- ipgno = 0;
- if (i != objc) {
- if (i != objc - 1) {
- Tcl_WrongNumArgs(interp, 2, objv, "?args? ?pgno?");
- result = TCL_ERROR;
- goto error;
- }
- result = Tcl_GetIntFromObj(interp, objv[i++], &ipgno);
- if (result != TCL_OK)
- goto error;
- }
-
- snprintf(newname, sizeof(newname), "%s.pg%d",
- mpip->i_name, mpip->i_mppgid);
- ip = _NewInfo(interp, NULL, newname, I_PG);
- if (ip == NULL) {
- Tcl_SetResult(interp, "Could not set up info",
- TCL_STATIC);
- return (TCL_ERROR);
- }
- _debug_check();
- pgno = (db_pgno_t)ipgno;
- ret = mp->get(mp, &pgno, NULL, flag, &page);
- result = _ReturnSetup(interp, ret, DB_RETOK_MPGET(ret), "mpool get");
- if (result == TCL_ERROR)
- _DeleteInfo(ip);
- else {
- /*
- * Success. Set up return. Set up new info
- * and command widget for this mpool.
- */
- mpip->i_mppgid++;
- ip->i_parent = mpip;
- ip->i_pgno = pgno;
- ip->i_pgsz = mpip->i_pgsz;
- _SetInfoData(ip, page);
- (void)Tcl_CreateObjCommand(interp, newname,
- (Tcl_ObjCmdProc *)pg_Cmd, (ClientData)page, NULL);
- res = NewStringObj(newname, strlen(newname));
- Tcl_SetObjResult(interp, res);
- }
-error:
- return (result);
-}
-
-/*
- * pg_Cmd --
- * Implements the "pg" widget.
- */
-static int
-pg_Cmd(clientData, interp, objc, objv)
- ClientData clientData; /* Page handle */
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
-{
- static const char *pgcmds[] = {
- "init",
- "is_setto",
- "pgnum",
- "pgsize",
- "put",
- NULL
- };
- enum pgcmds {
- PGINIT,
- PGISSET,
- PGNUM,
- PGSIZE,
- PGPUT
- };
- DB_MPOOLFILE *mp;
- int cmdindex, length, result;
- char *obj_name;
- void *page;
- DBTCL_INFO *pgip;
- Tcl_Obj *res;
-
- Tcl_ResetResult(interp);
- page = (void *)clientData;
- obj_name = Tcl_GetStringFromObj(objv[0], &length);
- pgip = _NameToInfo(obj_name);
- mp = NAME_TO_MP(pgip->i_parent->i_name);
- result = TCL_OK;
-
- if (page == NULL) {
- Tcl_SetResult(interp, "NULL page pointer", TCL_STATIC);
- return (TCL_ERROR);
- }
- if (mp == NULL) {
- Tcl_SetResult(interp, "NULL mp pointer", TCL_STATIC);
- return (TCL_ERROR);
- }
- if (pgip == NULL) {
- Tcl_SetResult(interp, "NULL page 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], pgcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
- return (IS_HELP(objv[1]));
-
- res = NULL;
- switch ((enum pgcmds)cmdindex) {
- case PGNUM:
- res = Tcl_NewWideIntObj((Tcl_WideInt)pgip->i_pgno);
- break;
- case PGSIZE:
- res = Tcl_NewWideIntObj((Tcl_WideInt)pgip->i_pgsz);
- break;
- case PGPUT:
- result = tcl_Pg(interp, objc, objv, page, mp, pgip);
- break;
- case PGINIT:
- result = tcl_PgInit(interp, objc, objv, page, pgip);
- break;
- case PGISSET:
- result = tcl_PgIsset(interp, objc, objv, page, pgip);
- break;
- }
-
- /*
- * Only set result if we have a res. Otherwise, lower
- * functions have already done so.
- */
- if (result == TCL_OK && res != NULL)
- Tcl_SetObjResult(interp, res);
- return (result);
-}
-
-static int
-tcl_Pg(interp, objc, objv, page, mp, pgip)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- void *page; /* Page pointer */
- DB_MPOOLFILE *mp; /* Mpool pointer */
- DBTCL_INFO *pgip; /* Info pointer */
-{
- static const char *pgopt[] = {
- "-discard",
- NULL
- };
- enum pgopt {
- PGDISCARD
- };
- u_int32_t flag;
- int i, optindex, result, ret;
-
- result = TCL_OK;
- i = 2;
- flag = 0;
- while (i < objc) {
- if (Tcl_GetIndexFromObj(interp, objv[i],
- pgopt, "option", TCL_EXACT, &optindex) != TCL_OK)
- return (IS_HELP(objv[i]));
- i++;
- switch ((enum pgopt)optindex) {
- case PGDISCARD:
- flag |= DB_MPOOL_DISCARD;
- break;
- }
- }
-
- _debug_check();
- ret = mp->put(mp, page, DB_PRIORITY_UNCHANGED, flag);
-
- result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret), "page");
-
- (void)Tcl_DeleteCommand(interp, pgip->i_name);
- _DeleteInfo(pgip);
- return (result);
-}
-
-static int
-tcl_PgInit(interp, objc, objv, page, pgip)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- void *page; /* Page pointer */
- DBTCL_INFO *pgip; /* Info pointer */
-{
- Tcl_Obj *res;
- long *p, *endp, newval;
- int length, pgsz, result;
- u_char *s;
-
- result = TCL_OK;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "val");
- return (TCL_ERROR);
- }
-
- pgsz = pgip->i_pgsz;
- result = Tcl_GetLongFromObj(interp, objv[2], &newval);
- if (result != TCL_OK) {
- s = Tcl_GetByteArrayFromObj(objv[2], &length);
- if (s == NULL)
- return (TCL_ERROR);
- memcpy(page, s, (size_t)((length < pgsz) ? length : pgsz));
- result = TCL_OK;
- } else {
- p = (long *)page;
- for (endp = p + ((u_int)pgsz / sizeof(long)); p < endp; p++)
- *p = newval;
- }
- res = Tcl_NewIntObj(0);
- Tcl_SetObjResult(interp, res);
- return (result);
-}
-
-static int
-tcl_PgIsset(interp, objc, objv, page, pgip)
- Tcl_Interp *interp; /* Interpreter */
- int objc; /* How many arguments? */
- Tcl_Obj *CONST objv[]; /* The argument objects */
- void *page; /* Page pointer */
- DBTCL_INFO *pgip; /* Info pointer */
-{
- Tcl_Obj *res;
- long *p, *endp, newval;
- int length, pgsz, result;
- u_char *s;
-
- result = TCL_OK;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "val");
- return (TCL_ERROR);
- }
-
- pgsz = pgip->i_pgsz;
- result = Tcl_GetLongFromObj(interp, objv[2], &newval);
- if (result != TCL_OK) {
- if ((s = Tcl_GetByteArrayFromObj(objv[2], &length)) == NULL)
- return (TCL_ERROR);
- result = TCL_OK;
-
- if (memcmp(page, s,
- (size_t)((length < pgsz) ? length : pgsz)) != 0) {
- res = Tcl_NewIntObj(0);
- Tcl_SetObjResult(interp, res);
- return (result);
- }
- } else {
- p = (long *)page;
- /*
- * If any value is not the same, return 0 (is not set to
- * this value). Otherwise, if we finish the loop, we return 1
- * (is set to this value).
- */
- for (endp = p + ((u_int)pgsz / sizeof(long)); p < endp; p++)
- if (*p != newval) {
- res = Tcl_NewIntObj(0);
- Tcl_SetObjResult(interp, res);
- return (result);
- }
- }
-
- res = Tcl_NewIntObj(1);
- Tcl_SetObjResult(interp, res);
- return (result);
-}
-#endif