tcl_compat.c

这是linux下运行的mysql软件包,可用于linux 下安装 php + mysql + apach 的网络配置

/*-
 * See the file LICENSE for redistribution information.
 *
 * Copyright (c) 1999-2001
 *	Sleepycat Software.  All rights reserved.
 */

#include "db_config.h"

#ifndef lint
static const char revid[] = "$Id: tcl_compat.c,v 11.39 2002/08/15 14:05:38 bostic Exp $";
#endif /* not lint */

#if CONFIG_TEST

#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 "dbinc/tcl_db.h"

/*
 * 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, DB_RETOK_STD(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);
		if (Tcl_GetIndexFromObj(interp, objv[4], srchacts,
		    "action", TCL_EXACT, &actindex) != TCL_OK)
			return (IS_HELP(objv[4]));
		switch ((enum srchacts)actindex) {
		case ACT_ENTER:
			action = ENTER;
			break;
		default:
		case ACT_FIND:
			action = FIND;
			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, ret;
	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) {
		ret = Tcl_GetErrno();
		result = _ReturnSetup(interp, ret, DB_RETOK_STD(ret),
		    "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;
	void *dtmp, *ktmp;
	u_int32_t size;
	int cmdindex, freedata, freekey, stindex, result, ret;
	char *name, *t;

	result = TCL_OK;
	freekey = freedata = 0;
	/*
	 * 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, DB_RETOK_STD(ret), "dbmclose");
		break;
	case DBMINIT:
		/*
		 * Must be 1 arg - file.