summaryrefslogtreecommitdiff
path: root/db/tcl/tcl_mp.c
diff options
context:
space:
mode:
Diffstat (limited to 'db/tcl/tcl_mp.c')
-rw-r--r--db/tcl/tcl_mp.c822
1 files changed, 822 insertions, 0 deletions
diff --git a/db/tcl/tcl_mp.c b/db/tcl/tcl_mp.c
new file mode 100644
index 000000000..b424deea2
--- /dev/null
+++ b/db/tcl/tcl_mp.c
@@ -0,0 +1,822 @@
+/*-
+ * 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_mp.c,v 11.24 2001/01/09 16:13:59 sue Exp $";
+#endif /* not lint */
+
+#ifndef NO_SYSTEM_INCLUDES
+#include <sys/types.h>
+
+#include <stdlib.h>
+#include <string.h>
+#include <tcl.h>
+#endif
+
+#include "db_int.h"
+#include "tcl_db.h"
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+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 *, int));
+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 *));
+
+/*
+ * _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);
+ }
+ }
+}
+
+/*
+ * tcl_MpSync --
+ *
+ * PUBLIC: int tcl_MpSync __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_MpSync(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+
+ DB_LSN lsn;
+ int result, ret;
+
+ result = TCL_OK;
+ /*
+ * No flags, must be 3 args.
+ */
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "lsn");
+ return (TCL_ERROR);
+ }
+
+ result = _GetLsn(interp, objv[2], &lsn);
+ if (result == TCL_ERROR)
+ return (result);
+
+ _debug_check();
+ ret = memp_sync(envp, &lsn);
+ result = _ReturnSetup(interp, ret, "memp sync");
+ return (result);
+}
+
+/*
+ * tcl_MpTrickle --
+ *
+ * PUBLIC: int tcl_MpTrickle __P((Tcl_Interp *, int,
+ * PUBLIC: Tcl_Obj * CONST*, DB_ENV *));
+ */
+int
+tcl_MpTrickle(interp, objc, objv, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+
+ int pages;
+ int percent;
+ int result;
+ int ret;
+ Tcl_Obj *res;
+
+ 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 = memp_trickle(envp, percent, &pages);
+ result = _ReturnSetup(interp, 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, 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 */
+{
+ static char *mpopts[] = {
+ "-create",
+ "-mode",
+ "-nommap",
+ "-pagesize",
+ "-rdonly",
+ NULL
+ };
+ enum mpopts {
+ MPCREATE,
+ MPMODE,
+ 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 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;
+ 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;
+ }
+ 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);
+ }
+ /*
+ * XXX finfop is NULL here. Interface currently doesn't
+ * have all the stuff. Should expand interface.
+ */
+ _debug_check();
+ ret = memp_fopen(envp, file, flag, mode, (size_t)pgsize, NULL, &mpf);
+ if (ret != 0) {
+ result = _ReturnSetup(interp, ret, "mpool");
+ _DeleteInfo(ip);
+ } else {
+ /*
+ * 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);
+ Tcl_CreateObjCommand(interp, newname,
+ (Tcl_ObjCmdProc *)mp_Cmd, (ClientData)mpf, NULL);
+ res = Tcl_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, envp)
+ Tcl_Interp *interp; /* Interpreter */
+ int objc; /* How many arguments? */
+ Tcl_Obj *CONST objv[]; /* The argument objects */
+ DB_ENV *envp; /* Environment pointer */
+{
+ DB_MPOOL_STAT *sp;
+ DB_MPOOL_FSTAT **fsp, **savefsp;
+ 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 = memp_stat(envp, &sp, &fsp, NULL);
+ result = _ReturnSetup(interp, 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();
+ /*
+ * MAKE_STAT_LIST assumes 'res' and 'error' label.
+ */
+ MAKE_STAT_LIST("Region size", sp->st_regsize);
+ MAKE_STAT_LIST("Cache size (gbytes)", sp->st_gbytes);
+ MAKE_STAT_LIST("Cache size (bytes)", sp->st_bytes);
+ MAKE_STAT_LIST("Cache hits", sp->st_cache_hit);
+ MAKE_STAT_LIST("Cache misses", sp->st_cache_miss);
+ MAKE_STAT_LIST("Number of caches", sp->st_ncache);
+ MAKE_STAT_LIST("Pages mapped into address space", sp->st_map);
+ MAKE_STAT_LIST("Pages created", sp->st_page_create);
+ MAKE_STAT_LIST("Pages read in", sp->st_page_in);
+ MAKE_STAT_LIST("Pages written", sp->st_page_out);
+ MAKE_STAT_LIST("Clean page evictions", sp->st_ro_evict);
+ MAKE_STAT_LIST("Dirty page evictions", sp->st_rw_evict);
+ MAKE_STAT_LIST("Hash buckets", sp->st_hash_buckets);
+ MAKE_STAT_LIST("Hash lookups", sp->st_hash_searches);
+ MAKE_STAT_LIST("Longest hash chain found", sp->st_hash_longest);
+ MAKE_STAT_LIST("Hash elements examined", sp->st_hash_examined);
+ MAKE_STAT_LIST("Cached clean pages", sp->st_page_clean);
+ MAKE_STAT_LIST("Cached dirty pages", sp->st_page_dirty);
+ MAKE_STAT_LIST("Dirty pages trickled", sp->st_page_trickle);
+ MAKE_STAT_LIST("Number of region lock waits", sp->st_region_wait);
+ MAKE_STAT_LIST("Number of region lock nowaits", sp->st_region_nowait);
+ /*
+ * 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;
+ savefsp = fsp;
+ for (; fsp != NULL && *fsp != NULL; fsp++) {
+ res = Tcl_NewObj();
+ result = _SetListElem(interp, res, "File Name",
+ strlen("File Name"), (*fsp)->file_name,
+ strlen((*fsp)->file_name));
+ if (result != TCL_OK)
+ goto error;
+ MAKE_STAT_LIST("Page size", (*fsp)->st_pagesize);
+ MAKE_STAT_LIST("Cache Hits", (*fsp)->st_cache_hit);
+ MAKE_STAT_LIST("Cache Misses", (*fsp)->st_cache_miss);
+ MAKE_STAT_LIST("Pages mapped into address space",
+ (*fsp)->st_map);
+ MAKE_STAT_LIST("Pages created", (*fsp)->st_page_create);
+ MAKE_STAT_LIST("Pages read in", (*fsp)->st_page_in);
+ MAKE_STAT_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;
+ }
+ Tcl_SetObjResult(interp, res1);
+error:
+ __os_free(sp, sizeof(*sp));
+ if (savefsp != NULL)
+ __os_free(savefsp, 0);
+ 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 char *mpcmds[] = {
+ "close", "fsync", "get",
+ NULL
+ };
+ enum mpcmds {
+ MPCLOSE, MPFSYNC, MPGET
+ };
+ DB_MPOOLFILE *mp;
+ int cmdindex, length, result, ret;
+ DBTCL_INFO *mpip;
+ Tcl_Obj *res;
+ char *obj_name;
+
+ 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 = memp_fclose(mp);
+ result = _ReturnSetup(interp, 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 = memp_fsync(mp);
+ res = Tcl_NewIntObj(ret);
+ break;
+ case MPGET:
+ result = tcl_MpGet(interp, objc, objv, mp, mpip);
+ 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 char *mpget[] = {
+ "-create", "-last", "-new",
+ NULL
+ };
+ enum mpget {
+ MPGET_CREATE, MPGET_LAST, MPGET_NEW
+ };
+
+ DBTCL_INFO *ip;
+ Tcl_Obj *res;
+ db_pgno_t pgno;
+ u_int32_t flag;
+ int i, ipgno, optindex, result, ret;
+ char newname[MSG_SIZE];
+ void *page;
+
+ 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_LAST:
+ flag |= DB_MPOOL_LAST;
+ break;
+ case MPGET_NEW:
+ flag |= DB_MPOOL_NEW;
+ 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 = ipgno;
+ ret = memp_fget(mp, &pgno, flag, &page);
+ result = _ReturnSetup(interp, 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);
+ Tcl_CreateObjCommand(interp, newname,
+ (Tcl_ObjCmdProc *)pg_Cmd, (ClientData)page, NULL);
+ res = Tcl_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 char *pgcmds[] = {
+ "init",
+ "is_setto",
+ "pgnum",
+ "pgsize",
+ "put",
+ "set",
+ NULL
+ };
+ enum pgcmds {
+ PGINIT,
+ PGISSET,
+ PGNUM,
+ PGSIZE,
+ PGPUT,
+ PGSET
+ };
+ 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_NewIntObj(pgip->i_pgno);
+ break;
+ case PGSIZE:
+ res = Tcl_NewLongObj(pgip->i_pgsz);
+ break;
+ case PGSET:
+ case PGPUT:
+ result = tcl_Pg(interp, objc, objv, page, mp, pgip,
+ cmdindex == PGSET ? 0 : 1);
+ 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)
+ Tcl_SetObjResult(interp, res);
+ return (result);
+}
+
+static int
+tcl_Pg(interp, objc, objv, page, mp, pgip, putop)
+ 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 */
+ int putop; /* Operation */
+{
+ static char *pgopt[] = {
+ "-clean", "-dirty", "-discard",
+ NULL
+ };
+ enum pgopt {
+ PGCLEAN, PGDIRTY, 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 PGCLEAN:
+ flag |= DB_MPOOL_CLEAN;
+ break;
+ case PGDIRTY:
+ flag |= DB_MPOOL_DIRTY;
+ break;
+ case PGDISCARD:
+ flag |= DB_MPOOL_DISCARD;
+ break;
+ }
+ }
+
+ _debug_check();
+ if (putop)
+ ret = memp_fput(mp, page, flag);
+ else
+ ret = memp_fset(mp, page, flag);
+
+ result = _ReturnSetup(interp, ret, "page");
+
+ if (putop) {
+ (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;
+ size_t pgsz;
+ long *p, *endp, newval;
+ int length, 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 + (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;
+ size_t pgsz;
+ long *p, *endp, newval;
+ int length, 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 + (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);
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-01 19:55:06 +0000