C++ Tcl_EvalObjEx函数代码示例

/* + style theme settings $theme $script
 *
 * 	Temporarily sets the current theme to $themeName,
 * 	evaluates $script, then restores the old theme.
 */
static int
StyleThemeSettingsCmd(
    ClientData clientData,		/* Master StylePackageData pointer */
    Tcl_Interp *interp,			/* Current interpreter */
    int objc,				/* Number of arguments */
    Tcl_Obj *const objv[])		/* Argument objects */
{
    StylePackageData *pkgPtr = clientData;
    Ttk_Theme oldTheme = pkgPtr->currentTheme;
    Ttk_Theme newTheme;
    int status;

    if (objc != 5) {
	Tcl_WrongNumArgs(interp, 3, objv, "theme script");
	return TCL_ERROR;
    }

    newTheme = LookupTheme(interp, pkgPtr, Tcl_GetString(objv[3]));
    if (!newTheme)
	return TCL_ERROR;

    pkgPtr->currentTheme = newTheme;
    status = Tcl_EvalObjEx(interp, objv[4], 0);
    pkgPtr->currentTheme = oldTheme;

    return status;
}

/* This function is used instead of the snack_sndfile_ext.tcl script in order
   to generate the tcl variables that are needed by snack. Doing it here allows
   keeping the formats always up to date with the current version of libsndfile
*/
int CreateTclVariablesForSnack(Tcl_Interp *interp)
{
  int k, count ;
  SF_FORMAT_INFO format_info ;
  Tcl_Obj *scriptPtr = Tcl_NewStringObj("", 0);
  Tcl_Obj *scriptPtr1 = Tcl_NewStringObj("", 0);
  Tcl_Obj *scriptPtr2 = Tcl_NewStringObj("", 0);
  Tcl_Obj *formatExtUC = Tcl_NewStringObj("", 0);

  Tcl_AppendStringsToObj(scriptPtr,
			 "namespace eval snack::snack_sndfile_ext {\n",
			 "    variable extTypes\n",
			 "    variable loadTypes\n",
			 "    variable loadKeys\n\n", (char *) NULL);
  Tcl_AppendStringsToObj(scriptPtr1, "    set extTypesMC {\n", (char *) NULL);
  Tcl_AppendStringsToObj(scriptPtr2, "    set loadTypes {\n", (char *) NULL);

  sf_command (NULL, SFC_GET_FORMAT_MAJOR_COUNT, &count, sizeof (int));
  
  for (k = 0 ; k < count ; k++) {
    format_info.format = k ;
    sf_command (NULL, SFC_GET_FORMAT_MAJOR, &format_info, sizeof (SF_FORMAT_INFO));

    /* convert extension to upper case */
    Tcl_SetStringObj(formatExtUC, format_info.extension, strlen(format_info.extension));
    Tcl_UtfToUpper(Tcl_GetString(formatExtUC));

    /* append to variable extTypesMC */
    Tcl_AppendStringsToObj(scriptPtr1, "        {{", format_info.name,
			   "} .", format_info.extension, "}\n", (char *) NULL);

    /* append to variable loadTypes */
    Tcl_AppendStringsToObj(scriptPtr2, "        {{", format_info.name,
			   "} {.", format_info.extension,
			   " .", Tcl_GetString(formatExtUC),
			   "}}\n", (char *) NULL);
  }
  Tcl_AppendStringsToObj(scriptPtr1, "    }\n\n", (char *) NULL);
  Tcl_AppendStringsToObj(scriptPtr2, "    }\n\n", (char *) NULL);

  Tcl_AppendObjToObj(scriptPtr, scriptPtr1);
  Tcl_AppendObjToObj(scriptPtr, scriptPtr2);

  Tcl_AppendStringsToObj(scriptPtr,
			 "    set extTypes [list]\n",
			 "    set loadKeys [list]\n",
			 "    foreach pair $extTypesMC {\n",
			 "	set type [string toupper [lindex $pair 0]]\n",
			 "	set ext [lindex $pair 1]\n",
			 "	lappend extTypes [list $type $ext]\n",
			 "	lappend loadKeys $type\n"
			 "    }\n\n",
			 "    snack::addLoadTypes $loadTypes $loadKeys\n",
			 "    snack::addExtTypes $extTypes\n",
			 "}\n", (char *) NULL);

  /* fprintf(stderr, "%s\n", Tcl_GetString(scriptPtr)); */

  return Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT);
}

/* + style theme create name ?-parent $theme? ?-settings { script }?
 */
static int StyleThemeCreateCmd(
    ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
    StylePackageData *pkgPtr = clientData;
    static const char *optStrings[] =
    	 { "-parent", "-settings", NULL };
    enum { OP_PARENT, OP_SETTINGS };
    Ttk_Theme parentTheme = pkgPtr->defaultTheme, newTheme;
    Tcl_Obj *settingsScript = NULL;
    const char *themeName;
    int i;

    if (objc < 4 || objc % 2 != 0) {
	Tcl_WrongNumArgs(interp, 3, objv, "name ?-option value ...?");
	return TCL_ERROR;
    }

    themeName = Tcl_GetString(objv[3]);

    for (i=4; i < objc; i +=2) {
	int option;
	if (Tcl_GetIndexFromObj(
	    interp, objv[i], optStrings, "option", 0, &option) != TCL_OK)
	{
	    return TCL_ERROR;
	}

	switch (option) {
	    case OP_PARENT:
		parentTheme = LookupTheme(
		    interp, pkgPtr, Tcl_GetString(objv[i+1]));
		if (!parentTheme)
		    return TCL_ERROR;
	    	break;
	    case OP_SETTINGS:
		settingsScript = objv[i+1];
		break;
	}
    }

    newTheme = Ttk_CreateTheme(interp, themeName, parentTheme);
    if (!newTheme) {
	return TCL_ERROR;
    }

    /*
     * Evaluate the -settings script, if supplied:
     */
    if (settingsScript) {
	Ttk_Theme oldTheme = pkgPtr->currentTheme;
	int status;

	pkgPtr->currentTheme = newTheme;
	status = Tcl_EvalObjEx(interp, settingsScript, 0);
	pkgPtr->currentTheme = oldTheme;
	return status;
    } else {
	return TCL_OK;
    }
}

/*
 * Radiobutton 'invoke' subcommand:
 * 	Sets the radiobutton -variable to the -value, evaluates the -command.
 */
static int
RadiobuttonInvokeCommand(
    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
    Radiobutton *radioPtr = recordPtr;
    WidgetCore *corePtr = &radioPtr->core;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "invoke");
	return TCL_ERROR;
    }
    if (corePtr->state & TTK_STATE_DISABLED)
	return TCL_OK;

    if (Tcl_ObjSetVar2(interp,
	    radioPtr->radiobutton.variableObj, NULL,
	    radioPtr->radiobutton.valueObj,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)
	== NULL)
	return TCL_ERROR;

    if (WidgetDestroyed(corePtr))
	return TCL_ERROR;

    return Tcl_EvalObjEx(interp,
	radioPtr->radiobutton.commandObj, TCL_EVAL_GLOBAL);
}

static int
rcSeek (ClientData cd_, long offset, int seekMode, int* errorCodePtr)
{
  ReflectingChannel* chan = (ReflectingChannel*) cd_;
  int n = -1;

  Tcl_SavedResult sr;
  Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_seek);
  Tcl_Interp* ip = chan->_interp;

  Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewLongObj(offset));
  Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(seekMode));
  Tcl_SaveResult(ip, &sr);

  if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK &&
      Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK)
    chan->_watchMask = chan->_validMask;

  Tcl_RestoreResult(ip, &sr);
  Tcl_DecrRefCount(cmd);

  if (n < 0)
    *errorCodePtr = EINVAL;
  return n;
}

/*
** Returns 1 if data is ready, or 0 if not.
*/
static int next2(Tcl_Interp *interp, tclvar_cursor *pCur, Tcl_Obj *pObj){
  Tcl_Obj *p;

  if( pObj ){
    if( !pCur->pList2 ){
      p = Tcl_NewStringObj("array names", -1);
      Tcl_IncrRefCount(p);
      Tcl_ListObjAppendElement(0, p, pObj);
      Tcl_EvalObjEx(interp, p, TCL_EVAL_GLOBAL);
      Tcl_DecrRefCount(p);
      pCur->pList2 = Tcl_GetObjResult(interp);
      Tcl_IncrRefCount(pCur->pList2);
      assert( pCur->i2==0 );
    }else{
      int n = 0;
      pCur->i2++;
      Tcl_ListObjLength(0, pCur->pList2, &n);
      if( pCur->i2>=n ){
        Tcl_DecrRefCount(pCur->pList2);
        pCur->pList2 = 0;
        pCur->i2 = 0;
        return 0;
      }
    }
  }

  return 1;
}

/*
 * Checkbutton 'invoke' subcommand:
 * 	Toggles the checkbutton state.
 */
static int
CheckbuttonInvokeCommand(
    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
    Checkbutton *checkPtr = recordPtr;
    WidgetCore *corePtr = &checkPtr->core;
    Tcl_Obj *newValue;

    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "invoke");
	return TCL_ERROR;
    }
    if (corePtr->state & TTK_STATE_DISABLED)
	return TCL_OK;

    /*
     * Toggle the selected state.
     */
    if (corePtr->state & TTK_STATE_SELECTED)
	newValue = checkPtr->checkbutton.offValueObj;
    else
	newValue = checkPtr->checkbutton.onValueObj;

    if (Tcl_ObjSetVar2(interp,
	    checkPtr->checkbutton.variableObj, NULL, newValue,
	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)
	== NULL)
	return TCL_ERROR;

    if (WidgetDestroyed(corePtr))
	return TCL_ERROR;

    return Tcl_EvalObjEx(interp,
	checkPtr->checkbutton.commandObj, TCL_EVAL_GLOBAL);
}

static int
rcClose (ClientData cd_, Tcl_Interp* interp)
{
  ReflectingChannel* chan = (ReflectingChannel*) cd_;
  int n = -1;

  Tcl_SavedResult sr;
  Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1));
  Tcl_Interp* ip = chan->_interp;

  Tcl_SaveResult(ip, &sr);

  if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK)
    Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n);

  Tcl_RestoreResult(ip, &sr);
  Tcl_DecrRefCount(cmd);

  if (chan->_timer != NULL) {
    Tcl_DeleteTimerHandler(chan->_timer);
    chan->_timer = NULL;
  }

  Tcl_DecrRefCount(chan->_context);
  Tcl_DecrRefCount(chan->_seek);
  Tcl_DecrRefCount(chan->_read);
  Tcl_DecrRefCount(chan->_write);
  Tcl_DecrRefCount(chan->_name);
  Tcl_Free((char*) chan);

  return TCL_OK;
}

static int
rcInput (ClientData cd_, char* buf, int toRead, int* errorCodePtr)
{
  ReflectingChannel* chan = (ReflectingChannel*) cd_;
  int n = -1;

  if (chan->_validMask & TCL_READABLE) {
    Tcl_SavedResult sr;
    Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_read);
    Tcl_Interp* ip = chan->_interp;

    Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewIntObj(toRead));
    Tcl_SaveResult(ip, &sr);

    if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK) {
      void* s = Tcl_GetByteArrayFromObj(Tcl_GetObjResult(ip), &n);
      if (0 <= n && n <= toRead)
      	if (n > 0)
      	  memcpy(buf, s, n);
      	else
      	  chan->_watchMask &= ~TCL_READABLE;
      else
      	n = -1;
    }

    Tcl_RestoreResult(ip, &sr);
    Tcl_DecrRefCount(cmd);
  }

  if (n < 0)
    *errorCodePtr = EINVAL;
  return n;
}

static int
rcOutput (ClientData cd_, const char* buf, int toWrite, int* errorCodePtr)
{
  ReflectingChannel* chan = (ReflectingChannel*) cd_;
  int n = -1;

  if (chan->_validMask & TCL_WRITABLE) {
    Tcl_SavedResult sr;
    Tcl_Obj* cmd = rcBuildCmdList(chan, chan->_write);
    Tcl_Interp* ip = chan->_interp;

    Tcl_ListObjAppendElement(NULL, cmd,
	      		Tcl_NewByteArrayObj((unsigned char*) buf, toWrite));
    Tcl_SaveResult(ip, &sr);

    if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK &&
      	Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n) == TCL_OK)
      if (0 <= n && n <= toWrite)
      	chan->_watchMask = chan->_validMask;
      else
      	n = -1;

    Tcl_RestoreResult(ip, &sr);
    Tcl_DecrRefCount(cmd);
  }

  if (n < 0)
    *errorCodePtr = EINVAL;
  return n;
}

static int xQueryPhraseCb(
  const Fts5ExtensionApi *pApi, 
  Fts5Context *pFts, 
  void *pCtx
){
  F5tFunction *p = (F5tFunction*)pCtx;
  static sqlite3_int64 iCmd = 0;
  Tcl_Obj *pEval;
  int rc;

  char zCmd[64];
  F5tApi sApi;

  sApi.pApi = pApi;
  sApi.pFts = pFts;
  sprintf(zCmd, "f5t_2_%lld", iCmd++);
  Tcl_CreateObjCommand(p->interp, zCmd, xF5tApi, &sApi, 0);

  pEval = Tcl_DuplicateObj(p->pScript);
  Tcl_IncrRefCount(pEval);
  Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zCmd, -1));
  rc = Tcl_EvalObjEx(p->interp, pEval, 0);
  Tcl_DecrRefCount(pEval);
  Tcl_DeleteCommand(p->interp, zCmd);

  if( rc==TCL_OK ){
    rc = f5tResultToErrorCode(Tcl_GetStringResult(p->interp));
  }

  return rc;
}

static void tvfsExecTcl(
  Testvfs *p, 
  const char *zMethod,
  Tcl_Obj *arg1,
  Tcl_Obj *arg2,
  Tcl_Obj *arg3,
  Tcl_Obj *arg4
){
  int rc;                         /* Return code from Tcl_EvalObj() */
  Tcl_Obj *pEval;
  assert( p->pScript );

  assert( zMethod );
  assert( p );
  assert( arg2==0 || arg1!=0 );
  assert( arg3==0 || arg2!=0 );

  pEval = Tcl_DuplicateObj(p->pScript);
  Tcl_IncrRefCount(p->pScript);
  Tcl_ListObjAppendElement(p->interp, pEval, Tcl_NewStringObj(zMethod, -1));
  if( arg1 ) Tcl_ListObjAppendElement(p->interp, pEval, arg1);
  if( arg2 ) Tcl_ListObjAppendElement(p->interp, pEval, arg2);
  if( arg3 ) Tcl_ListObjAppendElement(p->interp, pEval, arg3);
  if( arg4 ) Tcl_ListObjAppendElement(p->interp, pEval, arg4);

  rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
  if( rc!=TCL_OK ){
    Tcl_BackgroundError(p->interp);
    Tcl_ResetResult(p->interp);
  }
}

static int
ConsoleOutput(
    ClientData instanceData,	/* Indicates which device to use. */
    const char *buf,		/* The data buffer. */
    int toWrite,		/* How many bytes to write? */
    int *errorCode)		/* Where to store error code. */
{
    ChannelData *data = instanceData;
    ConsoleInfo *info = data->info;

    *errorCode = 0;
    Tcl_SetErrno(0);

    if (info) {
	Tcl_Interp *consoleInterp = info->consoleInterp;

	if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
	    Tcl_DString ds;
	    Tcl_Encoding utf8 = Tcl_GetEncoding(NULL, "utf-8");

	    /*
	     * Not checking for utf8 == NULL.  Did not check for TCL_ERROR
	     * from Tcl_SetChannelOption() in Tk_InitConsoleChannels() either.
	     * Assumption is utf-8 Tcl_Encoding is reliably present.
	     */

	    const char *bytes
		    = Tcl_ExternalToUtfDString(utf8, buf, toWrite, &ds);
	    int numBytes = Tcl_DStringLength(&ds);
	    Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);

	    Tcl_FreeEncoding(utf8);

	    if (data->type == TCL_STDERR) {
		Tcl_ListObjAppendElement(NULL, cmd,
			Tcl_NewStringObj("stderr", -1));
	    } else {
		Tcl_ListObjAppendElement(NULL, cmd,
			Tcl_NewStringObj("stdout", -1));
	    }
	    Tcl_ListObjAppendElement(NULL, cmd,
		    Tcl_NewStringObj(bytes, numBytes));

	    Tcl_DStringFree(&ds);
	    Tcl_IncrRefCount(cmd);
	    Tcl_EvalObjEx(consoleInterp, cmd, TCL_EVAL_GLOBAL);
	    Tcl_DecrRefCount(cmd);
	}
    }
    return toWrite;
}

/* $button invoke --
 * 	Evaluate the button's -command.
 */
static int
ButtonInvokeCommand(
    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], void *recordPtr)
{
    Button *buttonPtr = recordPtr;
    if (objc > 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "invoke");
	return TCL_ERROR;
    }
    if (buttonPtr->core.state & TTK_STATE_DISABLED) {
	return TCL_OK;
    }
    return Tcl_EvalObjEx(interp, buttonPtr->button.commandObj, TCL_EVAL_GLOBAL);
}

static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    PromptType *promptPtr)	/* Points to type of prompt to print. Filled
				 * with PROMPT_NONE after a prompt is
				 * printed. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel outChannel, errChannel;

    if (*promptPtr == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
    defaultPrompt:
	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	if ((*promptPtr == PROMPT_START)
		&& (outChannel != (Tcl_Channel) NULL)) {
	    Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
		    strlen(DEFAULT_PRIMARY_PROMPT));
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    goto defaultPrompt;
	}
    }

    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    if (outChannel != (Tcl_Channel) NULL) {
	Tcl_Flush(outChannel);
    }
    *promptPtr = PROMPT_NONE;
}