tcl_compat.c

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

		 */
		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, DB_RETOK_STD(ret), "dbminit");
		break;
	case DBMFETCH:
		/*
		 * 1 arg for this.  Error if different.
		 */
		if (objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "key");
			return (TCL_ERROR);
		}
		if ((ret = _CopyObjBytes(
		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
			result = _ReturnSetup(interp, ret,
			    DB_RETOK_STD(ret), "dbm fetch");
			goto out;
		}
		key.dsize = size;
		key.dptr = (char *)ktmp;
		_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);
			result = TCL_ERROR;
			goto out;
		}
		if (data.dptr == NULL ||
		    (ret = __os_malloc(NULL, data.dsize + 1, &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(NULL, t);
		}
		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);
		}
		if ((ret = _CopyObjBytes(
		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
			result = _ReturnSetup(interp, ret,
			    DB_RETOK_STD(ret), "dbm fetch");
			goto out;
		}
		key.dsize = size;
		key.dptr = (char *)ktmp;
		if ((ret = _CopyObjBytes(
		    interp, objv[3], &dtmp, &size, &freedata)) != 0) {
			result = _ReturnSetup(interp, ret,
			    DB_RETOK_STD(ret), "dbm fetch");
			goto out;
		}
		data.dsize = size;
		data.dptr = (char *)dtmp;
		_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, DB_RETOK_STD(ret), "store");
		break;
	case DBMDELETE:
		/*
		 * 1 arg for this.  Error if different.
		 */
		if (objc != 3) {
			Tcl_WrongNumArgs(interp, 2, objv, "key");
			return (TCL_ERROR);
		}
		if ((ret = _CopyObjBytes(
		    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
			result = _ReturnSetup(interp, ret,
			    DB_RETOK_STD(ret), "dbm fetch");
			goto out;
		}
		key.dsize = size;
		key.dptr = (char *)ktmp;
		_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, DB_RETOK_STD(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, &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(NULL, t);
		}
		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);
			}
			if ((ret = _CopyObjBytes(
			    interp, objv[2], &ktmp, &size, &freekey)) != 0) {
				result = _ReturnSetup(interp, ret,
				    DB_RETOK_STD(ret), "dbm fetch");
				goto out;
			}
			key.dsize = size;
			key.dptr = (char *)ktmp;
			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, &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(NULL, t);
		}
		break;
	}
out:
	if (freedata)
		(void)__os_free(NULL, dtmp);
	if (freekey)
		(void)__os_free(NULL, ktmp);
	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, DB_RETOK_STD(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, DB_RETOK_STD(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);
}
#endif /* CONFIG_TEST */