Logo Search packages:      
Sourcecode: db3 version File versions  Download package

tcl_compat.c

/*-
 * 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_compat.c,v 11.22 2001/01/11 18:19:55 bostic 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

#define     DB_DBM_HSEARCH 1

#include "db_int.h"
#include "tcl_db.h"

/*
 * Prototypes for procedures defined later in this file:
 */
static int mutex_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));

/*
 * bdb_HCommand --
 *    Implements h* functions.
 *
 * PUBLIC: int bdb_HCommand __P((Tcl_Interp *, int, Tcl_Obj * CONST*));
 */
int
bdb_HCommand(interp, objc, objv)
      Tcl_Interp *interp;           /* Interpreter */
      int objc;               /* How many arguments? */
      Tcl_Obj *CONST objv[];        /* The argument objects */
{
      static char *hcmds[] = {
            "hcreate",
            "hdestroy",
            "hsearch",
            NULL
      };
      enum hcmds {
            HHCREATE,
            HHDESTROY,
            HHSEARCH
      };
      static char *srchacts[] = {
            "enter",
            "find",
            NULL
      };
      enum srchacts {
            ACT_ENTER,
            ACT_FIND
      };
      ENTRY item, *hres;
      ACTION action;
      int actindex, cmdindex, nelem, result, ret;
      Tcl_Obj *res;

      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], hcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
            return (IS_HELP(objv[1]));

      res = NULL;
      switch ((enum hcmds)cmdindex) {
      case HHCREATE:
            /*
             * Must be 1 arg, nelem.  Error if not.
             */
            if (objc != 3) {
                  Tcl_WrongNumArgs(interp, 2, objv, "nelem");
                  return (TCL_ERROR);
            }
            result = Tcl_GetIntFromObj(interp, objv[2], &nelem);
            if (result == TCL_OK) {
                  _debug_check();
                  ret = hcreate(nelem) == 0 ? 1: 0;
                  _ReturnSetup(interp, ret, "hcreate");
            }
            break;
      case HHSEARCH:
            /*
             * 3 args for this.  Error if different.
             */
            if (objc != 5) {
                  Tcl_WrongNumArgs(interp, 2, objv, "key data action");
                  return (TCL_ERROR);
            }
            item.key = Tcl_GetStringFromObj(objv[2], NULL);
            item.data = Tcl_GetStringFromObj(objv[3], NULL);
            action = 0;
            if (Tcl_GetIndexFromObj(interp, objv[4], srchacts,
                "action", TCL_EXACT, &actindex) != TCL_OK)
                  return (IS_HELP(objv[4]));
            switch ((enum srchacts)actindex) {
            case ACT_FIND:
                  action = FIND;
                  break;
            case ACT_ENTER:
                  action = ENTER;
                  break;
            }
            _debug_check();
            hres = hsearch(item, action);
            if (hres == NULL)
                  Tcl_SetResult(interp, "-1", TCL_STATIC);
            else if (action == FIND)
                  Tcl_SetResult(interp, (char *)hres->data, TCL_STATIC);
            else
                  /* action is ENTER */
                  Tcl_SetResult(interp, "0", TCL_STATIC);

            break;
      case HHDESTROY:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc != 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            (void)hdestroy();
            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);
}

/*
 *
 * bdb_NdbmOpen --
 *    Opens an ndbm database.
 *
 * PUBLIC: #if DB_DBM_HSEARCH != 0
 * PUBLIC: int bdb_NdbmOpen __P((Tcl_Interp *, int, Tcl_Obj * CONST*, DBM **));
 * PUBLIC: #endif
 */
int
bdb_NdbmOpen(interp, objc, objv, dbpp)
      Tcl_Interp *interp;           /* Interpreter */
      int objc;               /* How many arguments? */
      Tcl_Obj *CONST objv[];        /* The argument objects */
      DBM **dbpp;             /* Dbm pointer */
{
      static char *ndbopen[] = {
            "-create",
            "-mode",
            "-rdonly",
            "-truncate",
            "--",
            NULL
      };
      enum ndbopen {
            NDB_CREATE,
            NDB_MODE,
            NDB_RDONLY,
            NDB_TRUNC,
            NDB_ENDARG
      };

      u_int32_t open_flags;
      int endarg, i, mode, optindex, read_only, result;
      char *arg, *db;

      result = TCL_OK;
      open_flags = 0;
      endarg = mode = 0;
      read_only = 0;

      if (objc < 2) {
            Tcl_WrongNumArgs(interp, 2, objv, "?args?");
            return (TCL_ERROR);
      }

      /*
       * Get the option name index from the object based on the args
       * defined above.
       */
      i = 2;
      while (i < objc) {
            if (Tcl_GetIndexFromObj(interp, objv[i], ndbopen, "option",
                TCL_EXACT, &optindex) != TCL_OK) {
                  arg = Tcl_GetStringFromObj(objv[i], NULL);
                  if (arg[0] == '-') {
                        result = IS_HELP(objv[i]);
                        goto error;
                  } else
                        Tcl_ResetResult(interp);
                  break;
            }
            i++;
            switch ((enum ndbopen)optindex) {
            case NDB_CREATE:
                  open_flags |= O_CREAT;
                  break;
            case NDB_RDONLY:
                  read_only = 1;
                  break;
            case NDB_TRUNC:
                  open_flags |= O_TRUNC;
                  break;
            case NDB_MODE:
                  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 NDB_ENDARG:
                  endarg = 1;
                  break;
            } /* switch */

            /*
             * If, at any time, parsing the args we get an error,
             * bail out and return.
             */
            if (result != TCL_OK)
                  goto error;
            if (endarg)
                  break;
      }
      if (result != TCL_OK)
            goto error;

      /*
       * Any args we have left, (better be 0, or 1 left) is a
       * file name.  If we have 0, then an in-memory db.  If
       * there is 1, a db name.
       */
      db = NULL;
      if (i != objc && i != objc - 1) {
            Tcl_WrongNumArgs(interp, 2, objv, "?args? ?file?");
            result = TCL_ERROR;
            goto error;
      }
      if (i != objc)
            db = Tcl_GetStringFromObj(objv[objc - 1], NULL);

      /*
       * When we get here, we have already parsed all of our args
       * and made all our calls to set up the database.  Everything
       * is okay so far, no errors, if we get here.
       *
       * Now open the database.
       */
      if (read_only)
            open_flags |= O_RDONLY;
      else
            open_flags |= O_RDWR;
      _debug_check();
      if ((*dbpp = dbm_open(db, open_flags, mode)) == NULL) {
            result = _ReturnSetup(interp, Tcl_GetErrno(), "db open");
            goto error;
      }
      return (TCL_OK);

error:
      *dbpp = NULL;
      return (result);
}

/*
 * bdb_DbmCommand --
 *    Implements "dbm" commands.
 *
 * PUBLIC: #if DB_DBM_HSEARCH != 0
 * PUBLIC: int bdb_DbmCommand
 * PUBLIC:     __P((Tcl_Interp *, int, Tcl_Obj * CONST*, int, DBM *));
 * PUBLIC: #endif
 */
int
bdb_DbmCommand(interp, objc, objv, flag, dbm)
      Tcl_Interp *interp;           /* Interpreter */
      int objc;               /* How many arguments? */
      Tcl_Obj *CONST objv[];        /* The argument objects */
      int flag;               /* Which db interface */
      DBM *dbm;               /* DBM pointer */
{
      static char *dbmcmds[] = {
            "dbmclose",
            "dbminit",
            "delete",
            "fetch",
            "firstkey",
            "nextkey",
            "store",
            NULL
      };
      enum dbmcmds {
            DBMCLOSE,
            DBMINIT,
            DBMDELETE,
            DBMFETCH,
            DBMFIRST,
            DBMNEXT,
            DBMSTORE
      };
      static char *stflag[] = {
            "insert",   "replace",
            NULL
      };
      enum stflag {
            STINSERT,   STREPLACE
      };
      datum key, data;
      int cmdindex, stindex, result, ret;
      char *name, *t;

      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], dbmcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
            return (IS_HELP(objv[1]));

      switch ((enum dbmcmds)cmdindex) {
      case DBMCLOSE:
            /*
             * No arg for this.  Error if different.
             */
            if (objc != 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            if (flag == DBTCL_DBM)
                  ret = dbmclose();
            else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            _ReturnSetup(interp, ret, "dbmclose");
            break;
      case DBMINIT:
            /*
             * Must be 1 arg - file.
             */
            if (objc != 3) {
                  Tcl_WrongNumArgs(interp, 2, objv, "file");
                  return (TCL_ERROR);
            }
            name = Tcl_GetStringFromObj(objv[2], NULL);
            if (flag == DBTCL_DBM)
                  ret = dbminit(name);
            else {
                  Tcl_SetResult(interp, "Bad interface flag for command",
                      TCL_STATIC);
                  return (TCL_ERROR);
            }
            _ReturnSetup(interp, ret, "dbminit");
            break;
      case DBMFETCH:
            /*
             * 1 arg for this.  Error if different.
             */
            if (objc != 3) {
                  Tcl_WrongNumArgs(interp, 2, objv, "key");
                  return (TCL_ERROR);
            }
            key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
            _debug_check();
            if (flag == DBTCL_DBM)
                  data = fetch(key);
            else if (flag == DBTCL_NDBM)
                  data = dbm_fetch(dbm, key);
            else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            if (data.dptr == NULL ||
                (ret = __os_malloc(NULL, data.dsize + 1, NULL, &t)) != 0)
                  Tcl_SetResult(interp, "-1", TCL_STATIC);
            else {
                  memcpy(t, data.dptr, data.dsize);
                  t[data.dsize] = '\0';
                  Tcl_SetResult(interp, t, TCL_VOLATILE);
                  __os_free(t, data.dsize + 1);
            }
            break;
      case DBMSTORE:
            /*
             * 2 args for this.  Error if different.
             */
            if (objc != 4 && flag == DBTCL_DBM) {
                  Tcl_WrongNumArgs(interp, 2, objv, "key data");
                  return (TCL_ERROR);
            }
            if (objc != 5 && flag == DBTCL_NDBM) {
                  Tcl_WrongNumArgs(interp, 2, objv, "key data action");
                  return (TCL_ERROR);
            }
            key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
            data.dptr =
                (char *)Tcl_GetByteArrayFromObj(objv[3], &data.dsize);
            _debug_check();
            if (flag == DBTCL_DBM)
                  ret = store(key, data);
            else if (flag == DBTCL_NDBM) {
                  if (Tcl_GetIndexFromObj(interp, objv[4], stflag,
                      "flag", TCL_EXACT, &stindex) != TCL_OK)
                        return (IS_HELP(objv[4]));
                  switch ((enum stflag)stindex) {
                  case STINSERT:
                        flag = DBM_INSERT;
                        break;
                  case STREPLACE:
                        flag = DBM_REPLACE;
                        break;
                  }
                  ret = dbm_store(dbm, key, data, flag);
            } else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            _ReturnSetup(interp, ret, "store");
            break;
      case DBMDELETE:
            /*
             * 1 arg for this.  Error if different.
             */
            if (objc != 3) {
                  Tcl_WrongNumArgs(interp, 2, objv, "key");
                  return (TCL_ERROR);
            }
            key.dptr = (char *)Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
            _debug_check();
            if (flag == DBTCL_DBM)
                  ret = delete(key);
            else if (flag == DBTCL_NDBM)
                  ret = dbm_delete(dbm, key);
            else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            _ReturnSetup(interp, ret, "delete");
            break;
      case DBMFIRST:
            /*
             * No arg for this.  Error if different.
             */
            if (objc != 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            if (flag == DBTCL_DBM)
                  key = firstkey();
            else if (flag == DBTCL_NDBM)
                  key = dbm_firstkey(dbm);
            else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            if (key.dptr == NULL ||
                (ret = __os_malloc(NULL, key.dsize + 1, NULL, &t)) != 0)
                  Tcl_SetResult(interp, "-1", TCL_STATIC);
            else {
                  memcpy(t, key.dptr, key.dsize);
                  t[key.dsize] = '\0';
                  Tcl_SetResult(interp, t, TCL_VOLATILE);
                  __os_free(t, key.dsize + 1);
            }
            break;
      case DBMNEXT:
            /*
             * 0 or 1 arg for this.  Error if different.
             */
            _debug_check();
            if (flag == DBTCL_DBM) {
                  if (objc != 3) {
                        Tcl_WrongNumArgs(interp, 2, objv, NULL);
                        return (TCL_ERROR);
                  }
                  key.dptr = (char *)
                      Tcl_GetByteArrayFromObj(objv[2], &key.dsize);
                  data = nextkey(key);
            } else if (flag == DBTCL_NDBM) {
                  if (objc != 2) {
                        Tcl_WrongNumArgs(interp, 2, objv, NULL);
                        return (TCL_ERROR);
                  }
                  data = dbm_nextkey(dbm);
            } else {
                  Tcl_SetResult(interp,
                      "Bad interface flag for command", TCL_STATIC);
                  return (TCL_ERROR);
            }
            if (data.dptr == NULL ||
                (ret = __os_malloc(NULL, data.dsize + 1, NULL, &t)) != 0)
                  Tcl_SetResult(interp, "-1", TCL_STATIC);
            else {
                  memcpy(t, data.dptr, data.dsize);
                  t[data.dsize] = '\0';
                  Tcl_SetResult(interp, t, TCL_VOLATILE);
                  __os_free(t, data.dsize + 1);
            }
            break;
      }
      return (result);
}

/*
 * ndbm_Cmd --
 *    Implements the "ndbm" widget.
 *
 * PUBLIC: int ndbm_Cmd __P((ClientData, Tcl_Interp *, int, Tcl_Obj * CONST*));
 */
int
ndbm_Cmd(clientData, interp, objc, objv)
      ClientData clientData;        /* DB handle */
      Tcl_Interp *interp;           /* Interpreter */
      int objc;               /* How many arguments? */
      Tcl_Obj *CONST objv[];        /* The argument objects */
{
      static char *ndbcmds[] = {
            "clearerr",
            "close",
            "delete",
            "dirfno",
            "error",
            "fetch",
            "firstkey",
            "nextkey",
            "pagfno",
            "rdonly",
            "store",
            NULL
      };
      enum ndbcmds {
            NDBCLRERR,
            NDBCLOSE,
            NDBDELETE,
            NDBDIRFNO,
            NDBERR,
            NDBFETCH,
            NDBFIRST,
            NDBNEXT,
            NDBPAGFNO,
            NDBRDONLY,
            NDBSTORE
      };
      DBM *dbp;
      DBTCL_INFO *dbip;
      Tcl_Obj *res;
      int cmdindex, result, ret;

      Tcl_ResetResult(interp);
      dbp = (DBM *)clientData;
      dbip = _PtrToInfo((void *)dbp);
      result = TCL_OK;
      if (objc <= 1) {
            Tcl_WrongNumArgs(interp, 1, objv, "command cmdargs");
            return (TCL_ERROR);
      }
      if (dbp == NULL) {
            Tcl_SetResult(interp, "NULL db pointer", TCL_STATIC);
            return (TCL_ERROR);
      }
      if (dbip == NULL) {
            Tcl_SetResult(interp, "NULL db 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], ndbcmds, "command", TCL_EXACT, &cmdindex) != TCL_OK)
            return (IS_HELP(objv[1]));

      res = NULL;
      switch ((enum ndbcmds)cmdindex) {
      case NDBCLOSE:
            _debug_check();
            dbm_close(dbp);
            (void)Tcl_DeleteCommand(interp, dbip->i_name);
            _DeleteInfo(dbip);
            res = Tcl_NewIntObj(0);
            break;
      case NDBDELETE:
      case NDBFETCH:
      case NDBFIRST:
      case NDBNEXT:
      case NDBSTORE:
            result = bdb_DbmCommand(interp, objc, objv, DBTCL_NDBM, dbp);
            break;
      case NDBCLRERR:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc > 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            ret = dbm_clearerr(dbp);
            if (ret)
                  _ReturnSetup(interp, ret, "clearerr");
            else
                  res = Tcl_NewIntObj(ret);
            break;
      case NDBDIRFNO:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc > 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            ret = dbm_dirfno(dbp);
            res = Tcl_NewIntObj(ret);
            break;
      case NDBPAGFNO:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc > 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            ret = dbm_pagfno(dbp);
            res = Tcl_NewIntObj(ret);
            break;
      case NDBERR:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc > 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            ret = dbm_error(dbp);
            Tcl_SetErrno(ret);
            Tcl_SetResult(interp, Tcl_PosixError(interp), TCL_STATIC);
            break;
      case NDBRDONLY:
            /*
             * No args for this.  Error if there are some.
             */
            if (objc > 2) {
                  Tcl_WrongNumArgs(interp, 2, objv, NULL);
                  return (TCL_ERROR);
            }
            _debug_check();
            ret = dbm_rdonly(dbp);
            if (ret)
                  _ReturnSetup(interp, ret, "rdonly");
            else
                  res = Tcl_NewIntObj(ret);
            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);
}

/*
 * 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(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, "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, sizeof(*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, sizeof(*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, mp->env->lockfhp);
            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_NewIntObj(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);
}

Generated by  Doxygen 1.6.0   Back to index